用格式写数组

Question

需要数组 VBA 专家的帮助。不是按照下面的代码格式化范围内的每个单元格，是否可以将这种格式包含在数组中，以便一旦它写回范围，它就会在写入的同时格式化？

请注意，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

Answer 1

请尝试使用下一种方法。代码将在数组元素之间迭代，但不可能将格式保留在数组中......它将处理每个数组元素，只增加其行，根据每个案例定义（在单独的 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

我问的是相同字符串类型的出现次数。如果有很多，可以优化代码（我可以这样做）以使用字典，其中保留 Union 范围以立即格式化，最后。 但是每个类别类型。如果相同字符串类型的情况不是太多，则不会有太大收获...

根据使用的算法，第二个子使用的字符串类型，可以保存在一个数组中，使用起来效率更高一些。

已编辑:

请尝试以下优化方案。它首先将 oArr (col E:E) 中的唯一字符串放入字典中（作为键），并作为（构建的）相似单元格的项目 Union 范围（在 E:E 中).然后，它将立即 process/format 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 中），它的效率将更加明显。

请测试两个版本并发送有关效率差异的反馈。

为了快速创建测试环境，我创建了下一个子来增加现有（显示的）测试范围。将它乘以 500 倍，我得到了 3004 行的范围，可以在大约 30 秒内处理。更改格式非常耗时...我认为，使用 Union 范围似乎是为此目的制作相对较快代码的唯一方法。

用格式写数组

Write Array with Formats

arrays

vba

multidimensional-array