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
CodePudding user response：
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.