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

Answer 1

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.