Question

我最近发现可以使用以下单个命令在范围的每个单元格内设置值：

Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)) = MyMatrix

其中MyMatrix是2D矩阵，其尺寸为：Row2-Row1和Column2-Column1。

显然，如果我将相同的属性应用于每个单元格（假设为.Font.Bold - 当MyMatrix是布尔矩阵时），则它不起作用：

Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Font.Bold = MyMatrix

上面的命令使整个范围“粗体闪烁”几秒钟，然后没有任何反应。怎么样？

我肯定希望避免For周期，因为在我的代码中需要太长时间。

更新：即使我使用字符串MyMatrix和"normal"填充"bold"，然后写下：

Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Font.FontStyle = MyMatrix

我也尝试过（它不起作用）：

Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Cells.Font.FontStyle = MyMatrix

Answer 1

正如其他答案所说，.Font属性只能设置为标量值，而不能设置为矩阵，但可以一次设置批量范围。

解决此问题的一种方法是构造一个String，其中包含应该具有特定字体的所有单元格的单元格引用，而不是True和False的矩阵然后只需更改该范围的字体即可。 E.g。

Dim strRange as String
strRange = "A1,B7,C3,D1"    ' set this in a loop or whatever
Worksheet.Range(strRange).Font.Bold = True

Answer 2

根据Range.Value Property (Excel)的文档，“返回或设置表示指定范围值的Variant值”。此Variant值可以是一个值或值数组。所以

 With ActiveSheet

  .Range("A1:B3").Value = [{1,2;3,4;5,6}]  

  aValues = .Range("A1:B3").Value

 End With

会奏效。

但Range.Font Property (Excel)“返回表示指定对象字体的Font对象。”这意味着一个 Font对象，不一个Font个对象数组。所以

...
  aFonts = .Range("A1:B3").Font
...

不起作用。既不

...
  .Range("A1:B3").Font = aFonts
...

会奏效。

一个人可以做到

...
  Set oFont = .Range("A1:B3").Font
...

但oFont对于整个范围也是一个 Font对象。

所以

...
  oFont.FontStyle = "bold italic"
...

或

...
  oFont.Bold = True
...

总会影响整个范围。

<强>解决方案：

最好的想法是@SteveES。它使用的范围是所有单元格的并集，应该是粗体。但是这种方法只有在strRange的长度低于256时才有效。可以使用以下方法轻松测试此限制：

Dim strRange As String
For r = 1 To 125 Step 2
 strRange = strRange & "A" & r & ","
Next
strRange = Left(strRange, Len(strRange) - 1)
MsgBox Len(strRange)
With ActiveSheet
 .Range(strRange).Font.Bold = True
End With

这将在.Range(strRange).Font.Bold = True失败，因为Len(strRange)是259。如果r的循环仅为1到124，那么Len(strRange) = 254就会有效。

因此，如果要求具有随机数量的单元格，这些单元格应格式化为粗体且无法使用条件格式确定，那么对我而言，最高性能的解决方案实际上是循环和设置Application.ScreenUpdating = False的所有单元格的循环粗体。

Sub setRangeValuesWithStyles()

 lRows = 100
 lCells = 100

 ReDim aValues(1 To lRows, 1 To lCells) As Variant
 ReDim aFontBolds(1 To lRows, 1 To lCells) As Boolean

 For r = 1 To lRows
  For c = 1 To lCells
   Randomize
   iRnd = Int((100 * Rnd()) + 1)
   aValues(r, c) = IIf(iRnd < 50, "T" & iRnd, iRnd)
   Randomize
   iRnd = Int((100 * Rnd()) + 1)
   aFontBolds(r, c) = IIf(iRnd < 50, True, False)
  Next
 Next

 lStartRow = 5
 lStartCol = 5

 With ActiveSheet
  Set oRange = .Range(.Cells(lStartRow, lStartCol), .Cells(lStartRow + lRows - 1, lStartCol + lCells - 1))
  oRange.Value = aValues
  Application.ScreenUpdating = False
  For r = 1 To lRows
   For c = 1 To lCells
    oRange.Cells(r, c).Font.Bold = aFontBolds(r, c)
   Next
  Next
  Application.ScreenUpdating = True
 End With

End Sub

即使使用Union作为部分范围（例如每行中的单元格），性能也不是更好，但在我的测试中更糟糕。

Answer 3

正如其他人所指出的那样，这是不可能的，至少是以任何直接的方式。

如果你做了很多这样的事情，你可以把它抽象成一个子，一个：

关闭屏幕更新和自动计算计算
Bold的默认设置 - 布尔矩阵中的大多数
将整个范围设置为默认值
循环通过细胞，改变不超过一半的细胞
将屏幕更新和计算模式恢复为调用子资源时的状态

Sub BoldFace(MyRange As Range, MyMatrix As Variant)
    'The dimensions of MyRange and MyMatrix are assumed the same
    'no error checking

    Dim i As Long, j As Long, m As Long, n As Long
    Dim su As Boolean, ac As Long
    Dim default As Boolean
    Dim TrueCount As Long

    su = Application.ScreenUpdating
    Application.ScreenUpdating = False
    ac = Application.Calculation
    Application.Calculation = xlCalculationManual

    m = MyRange.Rows.Count
    n = MyRange.Columns.Count
    For i = 1 To m
        For j = 1 To n
            If MyMatrix(i, j) Then TrueCount = TrueCount + 1
        Next j
    Next i

    default = TrueCount > m * n / 2 'defaults to true if over half the matrix is true
    MyRange.Font.Bold = default

    With MyRange
        For i = 1 To m
            For j = 1 To n
                If MyMatrix(i, j) = Not default Then .Cells(i, j).Font.Bold = MyMatrix(i, j)
            Next j
        Next i
    End With

    Application.ScreenUpdating = su
    Application.Calculation = ac
End Sub

测试如下：

Sub test()
    Dim i As Long, j As Long
    Dim R As Range, m As Variant
    Dim start As Double, elapsed As Double

    Randomize

    ReDim m(1 To 10000, 1 To 100)
    For i = 1 To 10000
        For j = 1 To 100
            m(i, j) = Rnd() < 0.9
        Next j
    Next i

    Set R = Range(Cells(1, 1), Cells(10000, 100)) '1 million cells!
    start = Timer
    BoldFace R, m
    elapsed = Timer - start
    Debug.Print elapsed

End Sub

当我以这种方式运行时，需要更换500,000个单元（平均），我的机器需要大约15.3秒。如果我将行m(i, j) = Rnd() < 0.5更改为m(i, j) = Rnd() < 0.1（因此只需要更改10％的单元格），则需要大约3.3秒。

On Edit 我很想知道@SteveES的想法会如何发展。以下是一种非侵略性方法，它逐行进行，更多地是作为概念证明。更积极的方法会等到Union抛出错误然后放电：

Sub BoldFace(MyRange As Range, MyMatrix As Variant)
    'The dimensions of MyRange and MyMatrix are assumed the same
    'no error checking

    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim lim As Long, needsFixed As String, toFix As Range
    Dim su As Boolean, ac As Long
    Dim default As Boolean
    Dim TrueCount As Long

    su = Application.ScreenUpdating
    Application.ScreenUpdating = False
    ac = Application.Calculation
    Application.Calculation = xlCalculationManual

    m = MyRange.Rows.Count
    n = MyRange.Columns.Count

    For i = 1 To m
        For j = 1 To n
            If MyMatrix(i, j) Then TrueCount = TrueCount + 1
        Next j
    Next i

    default = TrueCount > m * n / 2 'defaults to true if over half the matrix is true
    MyRange.Font.Bold = default

    With MyRange
        For i = 1 To m
            k = 0
            Set toFix = Nothing
            For j = 1 To n
                If MyMatrix(i, j) = Not default Then
                    k = k + 1
                    If toFix Is Nothing Then
                        Set toFix = .Cells(i, j)
                    Else
                        Set toFix = Union(toFix, .Cells(i, j))
                    End If
                End If
            Next j
            toFix.Font.Bold = Not default  
        Next i
    End With

    Application.ScreenUpdating = su
    Application.Calculation = ac
End Sub

无论如何，当我使用与上面完全相同的测试子运行此代码时，我的机器上需要大约7秒（而不是15秒）。如果通过在修复字体之前仅累积50-100个单元来节省50％，那么对于更具侵略性的方法可能会更好。

Answer 4

您可以在FormatCondition中使用矩阵来应用格式。

如果矩阵范围Sheet1!A1:B10中的对立单元格为Sheet2!A1:B10，则此示例会格式化范围True中的每个单元格：

' update the matrix
Range("Sheet2!A1:B10").Value2 = MyMatrix

' add a format condition
With Range("Sheet1!A1:B10").FormatConditions.Add(xlExpression, , "=Sheet2!A1:B10=True")
    .Font.Bold = True
    .Interior.Color = 255
End With

Answer 5

尝试此功能：

Rng_fBooleanProperties_ByArray(exRngProp, rTrg, aProperty)

用户定义的函数，用于设置以下Boolean Range Properties：AddIndent，Font.Bold，Font.Italic，Font.Strikethrough，Font.Subscript，Font.Superscript，FormulaHidden，Locked，ShrinkToFit，UseStandardHeight，UseStandardWidth和WrapText。如果成功，则返回True。

<强>语法

exRngProp As E_RngProp：自定义枚举，用于定义要更新的range property。

rTrg s Range：目标范围已更新。

aProperty As Variant：包含要更新的单元格的布尔数组。

使用：

•Array保持Target Range实际contents（即数字，文字，逻辑，错误，公式）。

•E_RngProp Enumeration定义和标识要更新的属性。

•Range.Value属性，用于将布尔数组输入Target Range。

•Range.Replace方法将False值更改为空单元格。

•Range.SpecialCell方法，根据需要使用每个Range.Property设置相应的Cell.Value。

这是代码：

Option Explicit

Enum E_RngProp
    Rem Range Properties - Boolean & Read\Write
    exAddIndent = 1
    exFontBold
    exFontItalic
    exFontStrikethrough
    exFontSubscript
    exFontSuperscript
    exFormulaHidden
    exLocked
    exShrinkToFit
    exUseStandardHeight
    exUseStandardWidth
    exWrapText
    End Enum

Function Rng_fBooleanProperties_ByArray(exRngProp As E_RngProp, rTrg As Range, aProperty As Variant) As Boolean
Dim rPropOn As Range
Dim aFml As Variant

    Rem Validate Input
    If rTrg Is Nothing Then Exit Function
    If Not IsArray(aProperty) Then Exit Function
    If rTrg.Rows.Count <> UBound(aProperty) Then Exit Function
    If rTrg.Columns.Count <> UBound(aProperty, 2) Then Exit Function

    With rTrg

        Rem Get Formulas from Target Range
        aFml = .Formula

        Rem Apply Bold Array to Target Range
        .Value = aProperty
        .Replace What:=False, Replacement:="", _
            LookAt:=xlWhole, SearchOrder:=xlByRows, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        On Error Resume Next
        Set rPropOn = .SpecialCells(xlCellTypeConstants, 23)
        On Error GoTo 0

        Select Case exRngProp
        Case exAddIndent
            .AddIndent = False
            If Not rPropOn Is Nothing Then rPropOn.AddIndent = True

        Case exFontBold
            .Font.Bold = False
            If Not rPropOn Is Nothing Then rPropOn.Font.Bold = True

        Case exFontItalic
            .Font.Italic = False
            If Not rPropOn Is Nothing Then rPropOn.Font.Italic = True

        Case exFontStrikethrough
            .Font.Strikethrough = False
            If Not rPropOn Is Nothing Then rPropOn.Font.Strikethrough = True

        Case exFontSubscript
            .Font.Subscript = False
            If Not rPropOn Is Nothing Then rPropOn.Font.Subscript = True

        Case exFontSuperscript
            .Font.Superscript = False
            If Not rPropOn Is Nothing Then rPropOn.Font.Superscript = True

        Case exFormulaHidden
            .FormulaHidden = False
            If Not rPropOn Is Nothing Then rPropOn.FormulaHidden = True

        Case exLocked
            .Locked = False
            If Not rPropOn Is Nothing Then rPropOn.Locked = True

        Case exShrinkToFit
            .Locked = False
            If Not rPropOn Is Nothing Then rPropOn.ShrinkToFit = True

        Case exUseStandardHeight
            .UseStandardHeight = False
            If Not rPropOn Is Nothing Then rPropOn.UseStandardHeight = True

        Case exUseStandardWidth
            .UseStandardWidth = False
            If Not rPropOn Is Nothing Then rPropOn.UseStandardWidth = True

        Case exWrapText
            .WrapText = False
            If Not rPropOn Is Nothing Then rPropOn.WrapText = True

        End Select

        Rem Reset Formulas in Target Range
        .Formula = aFml

    End With

    Rem Set Results
    Rng_fBooleanProperties_ByArray = True

End Function

另外，在主程序开始时使用这些行将有助于加快过程：

With Application
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

在主要程序结束时这些行：

With Application
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

可以使用以下任何方法调用该函数：

If Not (Rng_fBooleanProperties_ByArray(exFontBold, rTrg, aBold)) Then GoTo Error_Message

OR

Call Rng_fBooleanProperties_ByArray(exFontItalic, rTrg, aItalic)

OR

Rng_fBooleanProperties_ByArray exFontStrikethrough, rTrg, aStrikethrough

建议阅读以下页面以深入了解所使用的资源：

Enum Statement，Function Statement，On Error Statement，

Range Object (Excel)，Range.Replace Method (Excel)，Range.SpecialCells Method (Excel)，

Select Case Statement，Using Arrays，With Statement。

Answer 6

您可以使用临时虚拟工作表和“粘贴特殊”以获得不需要任何循环或持久数据更改的解决方案，可以一次应用多个字体，可以包含其他格式更改并且对大小有更大的限制（限制）只能通过命名范围中的单元格数量和Replace可以操作的单元格数量。）

首先创建/保存/粘贴布尔值矩阵到新的虚拟工作表/范围（或文本描述符一次处理多种格式）：

然后，对矩阵中的每种字体样式使用Replace方法一次，将文本替换为相同的文本，但将格式替换为相应的样式。然后，您有一个范围，其中包含要应用于实际数据的格式：

然后，您只需复制格式范围并使用PasteSpecial仅将格式粘贴到数据范围。最后，如果它不再有用，你可以删除虚拟工作表/范围。

这一切都可以在VBA中完成。如果要格式化的数据在命名范围内，则跟随子是完整的解决方案＆＃34;数据＆＃34;格式矩阵已在命名范围＆＃34;字体＆＃34; （仍然只是纯文本并使用上面第一张图片中的值，这可以通过将MyMatrix保存到新工作表并命名范围来完成。）

Sub CopyFonts()

    With Range("Fonts")
        Application.ReplaceFormat.Font.FontStyle = "Bold"
        .Replace What:="bold", Replacement:="bold", SearchFormat:=False, ReplaceFormat:=True
        Application.ReplaceFormat.Font.FontStyle = "Italic"
        .Replace What:="italics", Replacement:="italics", SearchFormat:=False, ReplaceFormat:=True
        .Copy
    End With

    Range("Data").PasteSpecial Paste:=xlPasteFormats

    Application.CutCopyMode = False

End Sub

我还做了一些性能测试以进行比较。我重复上述模式超过100万个单元格A1：J100000。从字体范围内的纯文本开始，总共需要16秒才能应用这两个替换并将格式粘贴到数据范围（Screenupdating设置为false）。

如果粗体是您想要的唯一FontStyle，并且您的矩阵只有TRUE和FALSE的值，那么只需保留应用粗体格式的2行代码，搜索＆＃34; TRUE＆＃34;的值。而不是＆＃34;粗体＆＃34;。或者，可以在替换格式中轻松指定其他或更复杂的格式。

Answer 7

这是不可能的。但是，你已经设置了赏金并花了一些积分，所以我可以提供一些相关的提示。因此，要保存代码，您可以将格式排列为VBA Styles。

所以你创建一个样式然后它是一个单行来设置范围。这应该可以节省一些时间。这是一些示例代码。

Option Explicit

Sub TestSetUpStyle()

    Dim stylFoo As Excel.Style
    On Error Resume Next
    Set stylFoo = ThisWorkbook.Styles.Item("foo")
    stylFoo.Delete
    Set stylFoo = Nothing
    On Error GoTo 0

    If stylFoo Is Nothing Then
        'https://msdn.microsoft.com/en-us/library/office/ff821826.aspx
        Set stylFoo = ThisWorkbook.Styles.Add("foo")

        '* I CAN SET ALL SORTS OF STYLE PROPERTIES ONCE HERE ...
        stylFoo.Font.Name = "Arial"
        stylFoo.Font.Size = 18

        stylFoo.Interior.ColorIndex = 3
        With stylFoo.Borders
            .LineStyle = xlContinuous
            .Color = vbRed
            .Weight = xlThin
        End With

        stylFoo.NumberFormat = "$000.00"

    End If

    Sheet1.UsedRange.Style = "foo" '* THEN IN ONE LINE WE SET ALL THOSE PROPERTIES

End Sub

同样适用于表格书写/格式化期间的速度设定Application.ScreenUpdating = False。您可以使用类来帮助使用RAII模式进行管理。

Excel VBA - 是否可以通过使用矩阵为某个范围的每个单元格设置属性？

7 个答案: