需要 Array VBA 專家的幫助。不是按照下面的代碼格式化范圍內的每個單元格，是否可以將此格式包含在 Array 中，以便一旦它寫回范圍，它在寫入的同時被格式化？
請注意，每個專案oArr都有不同的格式，如下所示
運行以下代碼后的當前輸出
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
uj5u.com熱心網友回復：
請嘗試使用下一種方法。代碼將在陣列元素之間迭代，但不可能在陣列中保持格式......它將根據每個案例定義（在單獨的子中）處理每個陣列元素，僅增加其行：
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
我詢問了相同字串型別的出現次數。如果有很多，則可以優化代碼（我可以這樣做）以使用字典來保存Union要立即格式化的范圍，最后。但是每個類別型別。如果相同字串型別的情況不多，那么收益不會太大...
根據使用的演算法，第二個 sub 使用的字串型別可以保存在一個陣列中，使用起來效率更高一些。
編輯：
請嘗試以下優化解決方案。它將首先將oArr(col E:E) 中的唯一字串放在字典中（作為鍵）和Union（構建的）相似單元格的專案范圍（在 E:E 中）。然后，它將立即處理/格式化Union范圍：
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
在相同字串出現更多的大范圍內（在 E:E 中），它的效率將更加明顯。
請測驗兩個版本并發送有關效率差異的反饋。
為了快速創建測驗環境，我創建了下一個 sub 來增加現有（顯示的）測驗范圍。乘以 500 倍，得到 3004 行的范圍，大約 30 秒可以處理完。更改格式是一件很耗時的事情……Union我認為，使用范圍似乎是為此目的制作相對較快的代碼的唯一方法。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/460549.html