Write Array with Formats - arrays

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.