Excel VBA - 是否可以通过使用矩阵为范围内的每个单元格设置属性？
Excel VBA - is it possible to set properties to each cell of a range through the use of a matrix?
我最近发现可以使用单个命令在范围的每个单元格内设置值，例如：
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)) = MyMatrix
其中 MyMatrix 是二维矩阵，维度为：Row2-Row1 和 Column2-Column1。
显然，如果我对每个单元格应用 属性 做同样的事情（假设 .Font.Bold - 当 MyMatrix 是布尔矩阵时），它不起作用:
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Font.Bold = MyMatrix
上面的命令使整个范围 "bold-flicker" 持续了几分之一秒，然后什么也没有发生。怎么会？
我绝对想避免 For 循环，因为在我的代码中它花费的时间太长了。
更新：即使我用字符串 "normal" 和 "bold" 填充 MyMatrix 然后写：
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
根据 Range.Value Property (Excel) 这个 "Returns or sets a Variant value that represents the value of the specified range" 的文档。此 Variant 值可以是一个值或一组值。所以
With ActiveSheet
.Range("A1:B3").Value = [{1,2;3,4;5,6}]
aValues = .Range("A1:B3").Value
End With
会起作用。
但是Range.Font Property (Excel)"Returns a Font object that represents the font of the specified object."。这意味着 一个 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，在我的测试中，性能并没有更好，反而更差。
正如其他答案所说，.Font 属性 只能设置为标量值，不能设置为矩阵，但它可以一次设置批量范围。
解决此问题的一种方法是构建一个 String，其中包含对应具有特定字体的所有单元格的单元格引用，而不是 True 和 [=14 的矩阵=] 等。然后只需更改该范围的字体。例如
Dim strRange as String
strRange = "A1,B7,C3,D1" ' set this in a loop or whatever
Worksheet.Range(strRange).Font.Bold = True
正如其他人所指出的，这是不可能的，至少以任何直接的方式是不可能的。
如果你经常做这类事情，你可以将它抽象为一个子程序，一个子程序：
- 关闭屏幕更新和自动计算计算
- 粗体的默认设置 -- 布尔矩阵中的多数
- 将整个范围设置为默认值
- 遍历单元格，更改不超过一半的单元格
- 将屏幕更新和计算模式恢复为调用子程序时的状态
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%，那么对于更激进的方法来说可能会更好。
您可以在 FormatCondition 中使用您的矩阵来应用格式。
如果矩阵范围 Sheet2!A1:B10 中的相对单元格为 True:
，则此示例格式化范围 Sheet1!A1:B10 中的每个单元格
' 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
这是不可能的。但是，你设置了赏金并花费了一些积分，所以我可以提供一些相关提示。因此，为了保存代码，您可以将格式排列成 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 = "[=10=]0.00"
End If
Sheet1.UsedRange.Style = "foo" '* THEN IN ONE LINE WE SET ALL THOSE PROPERTIES
End Sub
在 sheet writing/formatting 期间的速度也设置为 Application.ScreenUpdating = False。您可以使用 Class 来帮助使用 RAII 模式来管理它。
试试这个功能：
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。 Returns True 如果成功。
语法
exRngPropAs E_RngProp:自定义枚举来定义要更新的range property。
rTrgs Range：要更新的目标范围。
aPropertyAs Variant：包含要更新的单元格的布尔数组。
它使用：
• Array 用于保存 Target Range 实际 contents（即数字、文本、逻辑、错误、公式）。
• E_RngProp Enumeration 定义和标识要更新的 属性。
• Range.Value 属性 输入布尔数组进入Target Range.
• Range.Replace 方法将 False 值更改为空单元格。
• Range.SpecialCell方法使用每个Cell.Value.
根据需要设置相应的Range.Property
这是代码：
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
或
Call Rng_fBooleanProperties_ByArray(exFontItalic, rTrg, aItalic)
或
Rng_fBooleanProperties_ByArray exFontStrikethrough, rTrg, aStrikethrough
建议阅读以下页面以更深入地了解所使用的资源：
Enum Statement, Function Statement, On Error Statement,
Range Object (Excel), Range.Replace Method (Excel), Range.SpecialCells Method (Excel),
您可以使用临时虚拟工作sheet 和选择性粘贴作为不需要任何循环或持久数据更改的解决方案，可以一次应用多种字体，可以合并其他格式更改并且具有更大的大小限制（仅受命名范围中的单元格数量以及 Replace 可以操作的单元格数量的限制）。
首先 creating/saving/pasting 将您的布尔值矩阵转换为新的虚拟 worksheet/range（或一次处理多种格式的文本描述符）：
然后，对矩阵中的每种字体样式使用一次替换方法，将文本替换为相同的文本，但将格式替换为相应的样式。然后，您有一个范围，其中包含要应用于实际数据的格式：
然后，您只需复制格式范围并使用 PasteSpecial 仅将格式粘贴到您的数据范围。最后，如果虚拟 sheet/range 不再有用，您可以将其删除。
这一切都可以在 VBA 中非常简单地完成。如果要格式化的数据在命名范围 "Data" 中并且格式矩阵已在命名范围 "Fonts" 中构造（仍然像纯文本一样使用值，则跟随子是一个完整的解决方案上面的第一张图片，可以通过将 MyMatrix 保存到新的 sheet 并命名范围来完成。
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。从字体范围内的纯文本，应用两个替换并将格式粘贴到数据范围（将 Screenupdating 设置为 false）总共花费了 16 秒。
如果粗体是您想要的唯一 FontStyle，并且您的矩阵只有 TRUE 和 FALSE 值，那么只需保留应用粗体格式的 2 行代码，搜索 "TRUE" 的值而不是"bold"。或者，可以在替换格式中轻松指定其他或更复杂的格式。
我最近发现可以使用单个命令在范围的每个单元格内设置值，例如：
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)) = MyMatrix
其中 MyMatrix 是二维矩阵，维度为：Row2-Row1 和 Column2-Column1。
显然，如果我对每个单元格应用 属性 做同样的事情（假设 .Font.Bold - 当 MyMatrix 是布尔矩阵时），它不起作用:
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Font.Bold = MyMatrix
上面的命令使整个范围 "bold-flicker" 持续了几分之一秒，然后什么也没有发生。怎么会？
我绝对想避免 For 循环，因为在我的代码中它花费的时间太长了。
更新：即使我用字符串 "normal" 和 "bold" 填充 MyMatrix 然后写：
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
根据 Range.Value Property (Excel) 这个 "Returns or sets a Variant value that represents the value of the specified range" 的文档。此 Variant 值可以是一个值或一组值。所以
With ActiveSheet
.Range("A1:B3").Value = [{1,2;3,4;5,6}]
aValues = .Range("A1:B3").Value
End With
会起作用。
但是Range.Font Property (Excel)"Returns a Font object that represents the font of the specified object."。这意味着 一个 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，在我的测试中，性能并没有更好，反而更差。
正如其他答案所说，.Font 属性 只能设置为标量值，不能设置为矩阵，但它可以一次设置批量范围。
解决此问题的一种方法是构建一个 String，其中包含对应具有特定字体的所有单元格的单元格引用，而不是 True 和 [=14 的矩阵=] 等。然后只需更改该范围的字体。例如
Dim strRange as String
strRange = "A1,B7,C3,D1" ' set this in a loop or whatever
Worksheet.Range(strRange).Font.Bold = True
正如其他人所指出的，这是不可能的，至少以任何直接的方式是不可能的。
如果你经常做这类事情，你可以将它抽象为一个子程序，一个子程序：
- 关闭屏幕更新和自动计算计算
- 粗体的默认设置 -- 布尔矩阵中的多数
- 将整个范围设置为默认值
- 遍历单元格，更改不超过一半的单元格
- 将屏幕更新和计算模式恢复为调用子程序时的状态
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%，那么对于更激进的方法来说可能会更好。
您可以在 FormatCondition 中使用您的矩阵来应用格式。
如果矩阵范围 Sheet2!A1:B10 中的相对单元格为 True:
Sheet1!A1:B10 中的每个单元格
' 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
这是不可能的。但是，你设置了赏金并花费了一些积分，所以我可以提供一些相关提示。因此，为了保存代码，您可以将格式排列成 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 = "[=10=]0.00"
End If
Sheet1.UsedRange.Style = "foo" '* THEN IN ONE LINE WE SET ALL THOSE PROPERTIES
End Sub
在 sheet writing/formatting 期间的速度也设置为 Application.ScreenUpdating = False。您可以使用 Class 来帮助使用 RAII 模式来管理它。
试试这个功能：
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。 Returns True 如果成功。
语法
exRngPropAs E_RngProp:自定义枚举来定义要更新的range property。
rTrgs Range：要更新的目标范围。
aPropertyAs Variant：包含要更新的单元格的布尔数组。
它使用：
• Array 用于保存 Target Range 实际 contents（即数字、文本、逻辑、错误、公式）。
• E_RngProp Enumeration 定义和标识要更新的 属性。
• Range.Value 属性 输入布尔数组进入Target Range.
• Range.Replace 方法将 False 值更改为空单元格。
• Range.SpecialCell方法使用每个Cell.Value.
Range.Property
这是代码：
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
或
Call Rng_fBooleanProperties_ByArray(exFontItalic, rTrg, aItalic)
或
Rng_fBooleanProperties_ByArray exFontStrikethrough, rTrg, aStrikethrough
建议阅读以下页面以更深入地了解所使用的资源：
Enum Statement, Function Statement, On Error Statement,
Range Object (Excel), Range.Replace Method (Excel), Range.SpecialCells Method (Excel),
您可以使用临时虚拟工作sheet 和选择性粘贴作为不需要任何循环或持久数据更改的解决方案，可以一次应用多种字体，可以合并其他格式更改并且具有更大的大小限制（仅受命名范围中的单元格数量以及 Replace 可以操作的单元格数量的限制）。
首先 creating/saving/pasting 将您的布尔值矩阵转换为新的虚拟 worksheet/range（或一次处理多种格式的文本描述符）：
然后，对矩阵中的每种字体样式使用一次替换方法，将文本替换为相同的文本，但将格式替换为相应的样式。然后，您有一个范围，其中包含要应用于实际数据的格式：
然后，您只需复制格式范围并使用 PasteSpecial 仅将格式粘贴到您的数据范围。最后，如果虚拟 sheet/range 不再有用，您可以将其删除。
这一切都可以在 VBA 中非常简单地完成。如果要格式化的数据在命名范围 "Data" 中并且格式矩阵已在命名范围 "Fonts" 中构造（仍然像纯文本一样使用值，则跟随子是一个完整的解决方案上面的第一张图片，可以通过将 MyMatrix 保存到新的 sheet 并命名范围来完成。
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。从字体范围内的纯文本，应用两个替换并将格式粘贴到数据范围（将 Screenupdating 设置为 false）总共花费了 16 秒。
如果粗体是您想要的唯一 FontStyle，并且您的矩阵只有 TRUE 和 FALSE 值，那么只需保留应用粗体格式的 2 行代码，搜索 "TRUE" 的值而不是"bold"。或者，可以在替换格式中轻松指定其他或更复杂的格式。