时间戳

首页 > 解决方案 > VBA：从数组中批量设置范围对象的变量，而不是.value

arrays - VBA：从数组中批量设置范围对象的变量，而不是.value

问题描述

逐个单元格地设置范围对象的属性非常慢。除非只是将数组的全部内容放入 .value

例如。Range("A1:Z1000000").value = Arr

例如，如果要创建颜色图案，则必须逐个单元格地设置它。这可能需要很长时间。而不是只是将颜色设置为数组并立即设置整个属性。

就像一个简单的测试一样，如果可能的话，我希望它可以工作，但不幸的是它没有。

Sub test()

Dim Arr1() As Variant, Arr2() As Variant
Dim y As Long, x As Long
Dim Redfnt As Variant, blkfnt As Variant

Redfnt = RGB(0, 0, 0)
blkfnt = RGB(255, 0, 0)

Arr1 = Selection.Value
ReDim Arr2(1 To UBound(Arr1, 1), 1 To UBound(Arr1, 2))

For y = 1 To UBound(Arr1, 2)
    For x = 1 To UBound(Arr1, 1)

        Arr1(x, y) = Arr1(x, y) * 2

        If x Mod 2 = 0 Then
            Arr2(x, y) = Redfnt
        Else
            Arr2(x, y) = blkfnt
        End If

    Next x
Next y

Selection.Value = Arr1
Selection.Font.Color = Arr2


End Sub

有谁知道它是否可能？

标签： arraysexcelvbaperformanceoptimization

解决方案

你可以使用Autofilter()：

Sub test()

    Dim Arr1() As Variant

    Dim Redfnt As Variant, blkfnt As Variant
    Redfnt = RGB(0, 0, 0)
    blkfnt = RGB(255, 0, 0)

    With Selection ' reference selection object
        Arr1 = .Value ' store selection values
        With Intersect(.EntireRow, .Parent.UsedRange) ' reference the range with the same rows as 'Selection' and spanning all used range columns
            With .Resize(, 1).Offset(, .Columns.Count) ' reference a one column "helper" range right outside the used range in the same 'Selection' rows 
                .FormulaR1C1 = "=MOD(ROW(),2)" ' write referenced helper range with a formula giving the row evenness
                .Offset(-1).Resize(1).Value = "header" ' write a dummy header right on the top of referenced "helper" range
                With .Offset(-1).Resize(.Rows.Count + 1) ' expand the "helper" range to encompass the dummy header and reference it
                    .AutoFilter field:=1, Criteria1:="0" ' filter on even rows
                    Selection.SpecialCells(xlCellTypeVisible).Font.Color = Redfnt ' give filtered range its proper font color
                    .AutoFilter field:=1, Criteria1:="1" ' filter on uneven rows
                    Selection.SpecialCells(xlCellTypeVisible).Font.Color = blkfnt 'give filtered range its proper font color
                    .Parent.AutoFilterMode = False ' remove filters
                    .ClearContents ' clear "helper" range
                End With
            End With
        End With
    End With

    Dim y As Long, x As Long
    For y = 1 To UBound(Arr1, 2)
        For x = 1 To UBound(Arr1, 1)
            Arr1(x, y) = Arr1(x, y) * 2
        Next x
    Next y
    Selection.Value = Arr1

End Sub

推荐阅读