Write Array with Formats

Question

Need help from Array VBA expert. Instead of formatting each cell in a range as per code below, is it possible to get this format included in Array so that once it write back to range it is formatted at the same time of writing?

Note that each item in oArr has varying formats as shown below

The current output once I run the code below

Option Explicit

Sub Write_Array_With_Format()

    Dim xArr, aArr, bArr, sArr(), oArr() As Variant, lRow, i As Long, x, A, B As Double

    With Worksheets("Data")    'set data ranges to array
      lRow = .Cells(Rows.Count, 2).End(xlUp).Row
      xArr = .Range(.Cells(6, 2), .Cells(lRow, 2)).Value2
      aArr = .Range(.Cells(6, 3), .Cells(lRow, 3)).Value2
      bArr = .Range(.Cells(6, 4), .Cells(lRow, 4)).Value2
    End With
    
    ReDim sArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'String Array
    
    sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x")
    
    sArr = Application.Transpose(sArr)
    
    ReDim oArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'Output Array
    
    For i = 1 To UBound(xArr, 1)
    
        x = xArr(i, 1): A = aArr(i, 1): B = bArr(i, 1)
        
        If x > A And x > B And A > B Then
            oArr(i, 1) = sArr(1, 1)
        
        ElseIf x < A And x > B And A > B Then
            oArr(i, 1) = sArr(2, 1)

        ElseIf x < A And x < B And A > B Then
            oArr(i, 1) = sArr(3, 1)

        ElseIf x > A And x > B And A < B Then
            oArr(i, 1) = sArr(4, 1)

        ElseIf x > A And x < B And A < B Then
            oArr(i, 1) = sArr(5, 1)

        ElseIf x < A And x < B And A < B Then
            oArr(i, 1) = sArr(6, 1)
                
        End If

    Next
    
    With Worksheets("Data")
        .Range(.Cells(6, 5), .Cells(lRow, 5)).Value2 = oArr 'write Output Array to Range
        
        For i = 6 To lRow   'Format values
            
            If .Range("E" & i).Value = "x A B" Then
                With .Range("E" & i)
                    With .Characters(1, 1).Font
                        .Color = vbBlue
                    End With
                    With .Characters(3, 3).Font
                        .Underline = True
                        .Color = vbGreen
                    End With
                End With
            
            ElseIf .Range("E" & i).Value = "A x B" Then
                With .Range("E" & i)
                    With .Characters(1, 2).Font
                        .Color = vbGreen
                        .Underline = True
                    End With
                    With .Characters(3, 1).Font
                        .Underline = True
                        .Color = vbBlue
                    End With
                    With .Characters(5, 1).Font
                        .Color = vbGreen
                    End With
                End With
            
            'And so on and so forth.............
            
            End If
        Next
    
    End With
    
End Sub

You only have 6 distinct formats, so you could copy-paste from the first table or any pre-formatted range, instead of using the Characters collection for each cell. You can't store that type of formatting in your array — Tim Williams
– Tim Williams, Commented Apr 20, 2022 at 7:06
@TimWilliams thanks for the response, the formats are actually more than 6, it is 76 type of formats. Just made it 6 to explain it in simple way.. — Tope
– Tope, Commented Apr 20, 2022 at 8:15
Please, try explaining how can be 76 formats type, using only three characters (space separated) in the string? Could there be other characters, except A B and x? — FaneDuru
– FaneDuru, Commented Apr 20, 2022 at 9:10
@FaneDuru sorry for confusion, the 76 formats are actually based on 5 characters plus 4 spaces in between "A B C D x" or "x A B C D" or "A x B C D" or etc... with varying colors and varying underlined letter combinations. I just made it 3 to simply explain whether it is possible to get this format to array and write the format together with values to range. — Tope
– Tope, Commented Apr 20, 2022 at 9:42
It's always better to let us know if you've "simplified" your actual use case - approaches which might work for what you posted might fall apart or not be the best approach when scaled up... — Tim Williams
– Tim Williams, Commented Apr 20, 2022 at 16:02

FaneDuru · Accepted Answer · 2022-04-20 18:37:48Z

Please, try using the next approach. The code will iterate between the array elements, but it is not possible to keep format in an array... It will process each array element, only incrementing its rows, according to each case definition (in a separate Sub):

Sub testCellFormat()
 'Dim dict As New Scripting.Dictionary, i As Long
 Dim sh As Worksheet, lastR As Long, arr, oArr, sArr, arrFin, i As Long
 
 Set sh = ActiveSheet
 lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
 sh.Range("E6:E" & lastR).Font.Color = vbBlack 'just to reset the range for the second test...
 sh.Range("E6:E" & lastR).Font.Underline = False
 
 arr = sh.Range("B6:D" & lastR).Value2            'place all the range in a single aray
 sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x") 'A 1 D array is good enough, too
 
 ReDim oArr(1 To UBound(arr), 1 To 1)
 For i = 1 To UBound(arr)
        If arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(0)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(1)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(2)
        ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(3)
        ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(4)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(5)
        End If
    Next
    sh.Range("E" & 6).Resize(UBound(oArr), 1).value = oArr 'drop the array content
    For i = 1 To UBound(oArr)
        cellFormat sh.Range("E" & i + 5) 'process the necessary range (built using the iteration variable)
    Next i
End Sub

Sub cellFormat(rngE As Range)
   Dim T As String: T = rngE.value
   Dim boolUnderscore, boolGreen, boolRed, boolBlue
   If Len(T) <> 5 Then Exit Sub
   Select Case left(T, 3)
        Case "x A"
            rngE.Characters(1, 1).Font.Color = vbBlue
            With rngE.Characters(3, 3).Font
                .Color = vbGreen
                .Underline = True
            End With
        Case "A x"
            rngE.Characters(1, 3).Font.Underline = True
            rngE.Characters(1, 2).Font.Color = vbGreen
            rngE.Characters(3, 3).Font.Color = vbBlue
            rngE.Characters(5, 1).Font.Color = vbGreen
        Case "A B"
            rngE.Characters(1, 4).Font.Color = vbGreen
            rngE.Characters(5, 1).Font.Color = vbBlue
            rngE.Characters(3, 3).Font.Underline = True
        Case "x B"
            rngE.Characters(1, 3).Font.Underline = True
            rngE.Characters(1, 1).Font.Color = vbBlue
            rngE.Characters(2, 5).Font.Color = vbRed
        Case "B x"
            rngE.Characters(3, 5).Font.Underline = True
            rngE.Font.Color = vbRed
            rngE.Characters(3, 1).Font.Color = vbBlue
        Case "B A"
            With rngE.Characters(1, 3).Font
                .Color = vbRed
                .Underline = True
            End With
            rngE.Characters(5, 1).Font.Color = vbBlue
   End Select
End Sub

I asked about the occurrences number of the same string type. If there are many, the code can be optimized (I can do that) to use a dictionary where to keep a Union range to be formatted at once, of the end. But pere every category type. If not too many cases for the same string type, not much to be gain...

According to the used algorithm, the string types used by the second sub, can be kept in an array and use them a little more efficient.

Edited:

Please, try the following optimized solution. It will firstly place the unique strings from oArr (col E:E) in a dictionary (as keys) and as items Union ranges of (built) similar cells (in E:E). Then, it will process/format the Union ranges, at once:

Sub testCellFormat()
 Dim sh As Worksheet, lastR As Long, arr, oArr, sArr, arrFin, i As Long
 Dim dict As Object ' New Scripting.Dictionary
 
 Set sh = ActiveSheet
 lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
 sh.Range("E6:E" & lastR).Font.Color = vbBlack 'just to reset the range for the second test...
 sh.Range("E6:E" & lastR).Font.Underline = False
 
 arr = sh.Range("B6:D" & lastR).Value2            'place all the range in a single aray
 sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x") 'a 1 D array is good enough, too
 
 ReDim oArr(1 To UBound(arr), 1 To 1)
 For i = 1 To UBound(arr)                             'iterate between the array rows and appropriately fill oArr elements:
        If arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(0)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(1)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) > arr(i, 3) Then
            oArr(i, 1) = sArr(2)
        ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) > arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(3)
        ElseIf arr(i, 1) > arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(4)
        ElseIf arr(i, 1) < arr(i, 2) And arr(i, 1) < arr(i, 3) And arr(i, 2) < arr(i, 3) Then
            oArr(i, 1) = sArr(5)
        End If
    Next
    
    sh.Range("E" & 6).Resize(UBound(oArr), 1).Value2 = oArr 'drop the array content
    
    'place the not formatted range in a dictionary. Keys as oArr elements and items as (Union) build range:
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        If Not dict.Exists(oArr(i, 1)) Then
            dict.Add oArr(i, 1), sh.Range("E" & i + 5)
        Else
            Set dict(oArr(i, 1)) = Union(dict(oArr(i, 1)), sh.Range("E" & i + 5))
        End If
    Next
    'some optimization
    With Application
        .ScreenUpdating = False:
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    For i = 1 To UBound(oArr) 'iterate between oArr rows
        cellFormatDict CStr(oArr(i, 1)), sArr, dict 'format each dictionary Union ranges, at once
    Next i
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    MsgBox "Ready...", vbInformation, "Job done."
End Sub

Sub cellFormatDict(strCond As String, sArr, dict As Object)
    Select Case left(dict(strCond), 3)
        Case left(sArr(0), 3)   ' "x A"
            With dict(strCond)
                .Characters(1, 1).Font.Color = vbBlue
                With .Characters(3, 3).Font
                    .Color = vbGreen
                    .Underline = True
                End With
            End With
        Case left(sArr(1), 3)   ' "A x"
           With dict(strCond)
                .Characters(1, 3).Font.Underline = True
                .Characters(1, 2).Font.Color = vbGreen
                .Characters(3, 3).Font.Color = vbBlue
                .Characters(5, 1).Font.Color = vbGreen
            End With
         Case left(sArr(2), 3)   ' "A B"
            With dict(strCond)
                .Characters(1, 4).Font.Color = vbGreen
                .Characters(5, 1).Font.Color = vbBlue
                .Characters(3, 3).Font.Underline = True
            End With
         Case left(sArr(3), 3)  ' "x B"
            With dict(strCond)
                .Characters(1, 3).Font.Underline = True
                .Characters(1, 1).Font.Color = vbBlue
                .Characters(2, 5).Font.Color = vbRed
            End With
         Case left(sArr(4), 3)  ' "B x"
            With dict(strCond)
                .Characters(3, 5).Font.Underline = True
                .Font.Color = vbRed
                .Characters(3, 1).Font.Color = vbBlue
            End With
         Case left(sArr(5), 3)  ' "B A"
            With dict(strCond)
                With .Characters(1, 3).Font
                    .Color = vbRed
                    .Underline = True
                End With
                .Characters(5, 1).Font.Color = vbBlue
            End With
    End Select
End Sub

Its efficiency will be more visible in big ranges having more occurrences of the same strings (in E:E).

Please, test both versions and send feedback about the efficiency difference.

In order to rapidly create a testing environment, I created the next sub to multiply the existing (shown) testing range. Multiplying it by 500 times, I obtained a range of 3004 rows, which could be processed in about 30 seconds. Changing the format is something consuming time... Using the Union ranges looks to be the single way to make a relatively fast code for such a purpose, I think.

thanks for the response.. there are actually thousands of occurrence per file.. will try this out..
@Tope Not occurrences in general... Occurrences of the same string/category... If you confirm that this is the case and the meaning of your comment, when I will be at home (after some hours) I will try thinking about a solution, too
Once you've formatted one cell for any given format, you can copy/paste it for any later occurrences of the same pattern.
@FaneDuru - you're right about relative speed. I had the idea that using Characters to set formatting is relatively slow, but apparently not as nearly as slow as copying a single cell repeatedly. Nor would I ever have guessed you could use Characters on a multi-cell range.

Collectives™ on Stack Overflow

Write Array with Formats

1 Answer 1

9 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

9 Comments

Your Answer

Sign up or log in

Post as a guest

Related