Excel VBA – 是否可以通过使用matrix设置属性到一个范围的每个单元格？
我最近发现可以使用一个单独的命令来设置一个范围内的每个单元格的值：
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)) = MyMatrix MyMatrix是一个2Dmatrix，其尺寸为：Row2-Row1和Column2-Column1。
显然，如果我为每个单元格应用一个属性（假设.Font.Bold – 当MyMatrix是一个布尔matrix）时，它是行不通的：
Worksheet.Range(Worksheet.Cells(Row1, Column1), Worksheet.Cells(Row2, Column2)).Font.Bold = MyMatrix
上面的命令使整个范围“粗体闪烁”几分之一秒，然后没有任何反应。 怎么来的？
我一定要避免For循环，因为在我的代码中需要很长的时间。
更新：即使我用string"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属性（Excel）的文档，此“返回或设置表示指定范围的值的Variant值”。 此Variant值可以是一个值或一组值。 所以
With ActiveSheet .Range("A1:B3").Value = [{1,2;3,4;5,6}] aValues = .Range("A1:B3").Value End With
将工作。
但Range.Font属性（Excel） “返回一个Font对象，它表示指定对象的字体。” 这意味着一个 Font对象，而不是 一个 Font对象的数组。 所以
... aFonts = .Range("A1:B3").Font ...
不pipe用。 也不
... .Range("A1:B3").Font = aFonts ...
将工作。
人可以做
... Set oFont = .Range("A1:B3").Font ...
但是oFont也将是整个范围的一个 Font对象。
所以
... oFont.FontStyle = "bold italic" ...
要么
... oFont.Bold = True ...
将始终影响整个范围。
解决scheme：
最好的想法是真正的@SteveES之一。 它是使用一个范围，这是一个大胆的所有单元格的联合。 但是这种方法只有在strRange的长度低于256的时候才能工作。这个限制可以很容易的用下面的方法来testing：
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就可以工作。
因此，如果要求具有随机数的单元格，这些单元格的格式应该是粗体，而且不能使用条件格式来确定，那么对于我来说，最高性能的解决scheme实际上是循环遍历所有具有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的部分范围（例如，在每行的单元格），性能不是更好，但在我的testing中更糟糕。
正如其他答案所说， .Font属性只能设置为标量值，而不是matrix，但它可以一次设置批量范围。
解决这个问题的一个方法是构造一个String包含所有应该有特定字体的单元格的单元格引用，而不是一个True和False的matrix等等。然后只需要改变该范围的字体。 例如
Dim strRange as String strRange = "A1,B7,C3,D1" ' set this in a loop or whatever Worksheet.Range(strRange).Font.Bold = True
您可以在FormatCondition使用您的matrix来应用格式。
如果matrix范围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
正如其他人所指出的，这是不可能的，至less在任何直接的方式。
如果你这样做很多，你可以把它抽象成一个子，
- closures屏幕更新和自动计算计算
- 粗体的默认设置 – 布尔matrix中的大部分
- 将整个范围设置为默认值
- 循环通过细胞，改变不超过一半的细胞
- 将屏幕更新和计算模式恢复到子被调用时的状态
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
testing像：
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秒。
在编辑我很好奇，看看@SteveES的想法将如何泛滥。 下面是一个非侵略性的方法，它是逐行的，更多的是为了certificate概念。 更积极的方法将等待，直到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
在任何情况下，当我使用与上述完全相同的testing子代码运行此代码时，在我的机器上需要大约7秒（而不是15秒）。 如果在固定字体之前，只有50-100个单元，节省了50％，那么对于更积极的方法来说，这可能会更好。
试试这个function：
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 ：与要更新的单元格相关的布尔值数组。
它用：
•保存Target Range实际contents的Array （即数字，文本，逻辑，错误，公式）。
• E_RngProp Enumeration来定义和标识要更新的属性。
Range.Value属性将布尔数组input到Target Range 。
Range.Replace方法将False值更改为空单元格。
Range.SpecialCell方法根据需要使用每个Cell.Value来设置相应的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
要么
Call Rng_fBooleanProperties_ByArray(exFontItalic, rTrg, aItalic)
要么
Rng_fBooleanProperties_ByArray exFontStrikethrough, rTrg, aStrikethrough
build议阅读以下页面，以深入了解所使用的资源：
枚举语句 ， 函数语句 ， 错误语句 ，
范围对象（Excel） ， Range.Replace方法（Excel） ， Range.SpecialCells方法（Excel） ，
select案例陈述 ， 使用数组 ， 使用陈述 。
您可以使用临时虚拟工作表和“特殊选项”来解决此问题，而不需要任何循环或持久数据更改，可以一次应用多个字体，可以包含其他格式更改，并且具有更大的限制（仅限于指定范围内的单元格以及哪个Replace可以操作）。
首先创build/保存/粘贴布尔值的matrix到一个新的虚拟工作表/范围（或文本描述符一次处理多种格式）：
然后，对matrix中的每种字体样式使用一次replace方法，用相同的文本replace文本，但用相应的样式replace格式。 然后，您可以使用要应用于实际数据的格式。
然后，您只需复制格式范围并使用PasteSpecial将格式粘贴到您的数据范围。 最后，如果不再有用，可以删除虚拟纸张/范围。
这一切都可以很容易地在VBA中完成。 如果要格式化的数据位于命名范围“Data”中，并且格式matrix已经在命名范围“Fonts”中构build（仍然是纯文本并使用上面第一个图像的值，这可以通过保存你的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
我也做了一些比较性能testing。 我重复了上述模式，超过100万个单元格A1：J100000。 从字体范围内的纯文本，总共需要16秒来应用两个replace，并将格式粘贴到数据范围（将Screenupdating设置为false）。
如果bold是你想要的唯一的FontStyle，而你的matrix的值是TRUE和FALSE，那么只要保持应用粗体格式的两行代码，search值“TRUE”而不是“bold”。 或者，可以使用replace格式轻松指定更多或更复杂的格式。
这不可能。 但是，你已经设置了一个赏金，并花了一些点，所以我可以给一些相关的提示。 所以为了节省代码，您可以将您的格式安排到VBA样式中 。
所以你一次创build一个样式，然后设置一个范围。 这应该节省一些时间。 这里是一些示例代码。
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表的持续时间表写入/格式化。 你可以使用一个类来帮助pipe理这个使用RAII模式。