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

I recently found out that it is possible to set values inside each cell of a range with a single command like:

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

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

Where MyMatrix is a 2D matrix, with dimensions: Row2-Row1 and Column2-Column1.

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

Apparently though, if I do the same for applying a property to each cell (let's say .Font.Bold - when MyMatrix is a boolean matrix), it doesn't work:

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

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

The command above makes the whole range "bold-flicker" for a fraction of second and then nothing happens. How come?

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

I would definitely like to avoid the For cycle, because in my code it takes too long.

我肯定想避免使用For循环，因为在我的代码中它需要太长时间。

UPDATE: the same does not work even if I fill MyMatrix with the strings "normal" and "bold" and then write:

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

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

I also tried (and it doesn't work):

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

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

7 个解决方案

#1

According to the documentation of Range.Value Property (Excel) this "Returns or sets a Variant value that represents the value of the specified range". This Variant value can either be one value or an array of values. So

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

 With ActiveSheet

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

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

 End With

will work.

将工作。

But Range.Font Property (Excel) "Returns a Font object that represents the font of the specified object.". That means one Font object and not an array of Font objects. So

但Range.Font属性（Excel）“返回表示指定对象的字体的Font对象。”。这意味着一个Font对象而不是Font对象的数组。所以

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

will not work. Neither

不管用。也不

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

will work.

将工作。

---

One could do

一个人可以做到

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

but that oFont will also be one Font object for the whole range.

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

So

所以

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

or

要么

...
  oFont.Bold = True
...

will always affect the whole range.

将永远影响整个范围。

---

Solutions:

解决方案：

The best idea would really be the one of @SteveES. It is using a range which is a union of all cells which shall be bold. But this approach will only work if the length of strRange is lower than 256. This limit can easily be tested using the following:

最好的想法是@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

This will fail at .Range(strRange).Font.Bold = True because Len(strRange) is 259 . If the loop of r is from 1 to 124 only, then it will work having Len(strRange) = 254.

这将在.Range（strRange）.Font.Bold = True失败，因为Len（strRange）是259。如果r的循环仅为1到124，那么它将具有Len（strRange）= 254。

So if the requirement is having a random number of cells which shall be formatted bold and cannot be determinated using conditional formatting, the most performant solution for me is really a loop over all cells having Application.ScreenUpdating = False while looping and setting bold.

因此，如果要求具有随机数量的单元格，这些单元格应格式化为粗体并且无法使用条件格式确定，那么对我而言，性能最佳的解决方案实际上是循环并设置粗体时具有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

Even using Union for partially ranges (cells in each rows for example) the performance is not better but more worse in my tests.

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

#2

As other answers have said, the .Font property can only be set to a scalar value, not a matrix, but that it can set bulk ranges at once.

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

One way to get around this would be to construct a String containing the cell references to all the cells that should have a certain font, rather than a matrix of True and False etc. Then just change the font for that range. E.g.

解决这个问题的一种方法是构造一个String，其中包含对应该具有某种字体的所有单元格的单元格引用，而不是True和False等矩阵。然后只需更改该范围的字体。例如。

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

#3

You could use your matrix in a FormatCondition to apply the formatting.

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

This example formats each cell in range Sheet1!A1:B10 if the opposing cell in the matrix range Sheet2!A1:B10 is True:

此示例格式化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

#4

As others have pointed out, this isn't possible, at least in any direct way.

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

If you do this sort of thing a lot, you could abstract it to a sub, one which:

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

• Turns off screen-updating and automatic calculation Calculates the
• 关闭屏幕更新和自动计算计算
• default setting of Bold -- the majority in the Boolean matrix
• Bold的默认设置 - 布尔矩阵中的多数
• Sets the whole range to the default
• 将整个范围设置为默认值
• Loops through the cells, changing no more than half the cells
• 循环通过细胞，改变不超过一半的细胞
• Restores screen-updating and calculation mode to what they were when the sub was called
• 将屏幕更新和计算模式恢复为调用子网时的状态

---

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

Tested like:

测试如下：

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

When I run it this way, where 500,000 cells (on average) need to be changes, it takes about 15.3 seconds on my machine. If I change the line m(i, j) = Rnd() < 0.5 to m(i, j) = Rnd() < 0.1 (so only 10% of the cells will need to be changed) it takes about 3.3 seconds.

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

On Edit I was curious to see how the idea of @SteveES would pan out. The following is a non-aggressive approach that does it row by row, and is meant more as proof of concept. A more aggressive approach would wait until Union throws an error and then discharge then:

编辑我很想知道@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

In any event, when I run this code with exactly the same test sub as above then it takes around 7 seconds (rather than 15) on my machine. If the savings are 50% by only accumulating 50-100 cells before fixing the font, it would probably be even better for even more aggressive approaches.

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

#5

Try this function:

试试这个功能：

Rng_fBooleanProperties_ByArray(exRngProp, rTrg, aProperty)

User defined function that sets the following Boolean Range Properties: AddIndent, Font.Bold, Font.Italic, Font.Strikethrough, Font.Subscript, Font.Superscript, FormulaHidden, Locked, ShrinkToFit, UseStandardHeight, UseStandardWidth and WrapText. Returns True if successful.

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

Syntax

句法

exRngPropAs E_RngProp: Customized Enumeration to define the range property to be updated.

exRngPropAs E_RngProp：Customized Enumeration，用于定义要更新的range属性。

rTrgs Range: Target range to updated.

rTrgs范围：要更新的目标范围。

aPropertyAs Variant: Array of booleans with cells to be updated.

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

It uses:

它用：

• An Array to hold the Target Range actual contents (i.e. Numbers, Text, Logical, Error, Formulas).

•用于保存目标范围实际内容的数组（即数字，文本，逻辑，错误，公式）。

• The E_RngProp Enumeration to define and identify the property to be updated.

•E_RngProp枚举，用于定义和标识要更新的属性。

• The Range.Value property to enter the Boolean Array into the Target Range.

•Range.Value属性，用于将布尔数组输入目标范围。

• The Range.Replace method to change the False values into empty cells.

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

• The Range.SpecialCell method to set the corresponding Range.Property as required using each Cell.Value.

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

This is the code:

这是代码：

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

Additionally having these lines at the beginning of your main procedure will help to speed up the process:

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

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

And these lines at the end of your main procedure:

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

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

The function can be called using any of these methods:

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

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

Suggest to read the following pages to gain a deeper understanding of the resources used:

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

Enum Statement, Function Statement, On Error Statement,

枚举语句，函数语句，错误语句，

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

范围对象（Excel），Range.Replace方法（Excel），Range.SpecialCells方法（Excel），

Select Case Statement, Using Arrays, With Statement.

选择Case语句，使用数组，使用Statement。

#6

You could use a temporary dummy worksheet and Paste Special for a solution that doesn't require any looping or persistent data changes, can apply multiple fonts at once, can incorporate additional formatting changes and has larger limits on size (restricted only by the number of cells in named ranges and that which Replace can operate on).

您可以使用临时虚拟工作表和Paste Special来获得不需要任何循环或持久数据更改的解决方案，可以同时应用多个字体，可以包含其他格式更改并且对大小有更大的限制（仅受限于命名范围中的单元格和Replace可以操作的单元格。

Start by first creating/saving/pasting your matrix of boolean values to a new dummy worksheet/range (or text descriptors to handle multiple formats at once):

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

Then, use the Replace method once for each font style you have in your matrix, replacing the text with the same text but replacing the format with the corresponding style. You then have a range with the formatting that you want to apply to your actual data:

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

Then, you just copy the format range and use PasteSpecial to paste only the Formats onto your data range. Lastly you can delete the dummy sheet/range if it's no longer useful.

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

This can all be done in VBA fairly quite simply. The follow sub is a complete solution if the data to be formatted is in named range "Data" and the matrix of formats has been constructed in named range "Fonts" (still just as plain text and using the values as per the first image above, which can be done by saving your MyMatrix to a new sheet and naming the range).

这一切都可以在VBA中完全相当简单地完成。如果要格式化的数据在命名范围“数据”中并且格式矩阵已在命名范围“字体”中构建（仍然只是纯文本并使用上面第一个图像的值，则跟随子是完整的解决方案，可以通过将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

I've also done some performance testing for comparison. I repeated the above pattern over 1 million cells A1:J100000. From plain text in the fonts range, it took 16 seconds in total to apply the two replaces and paste the formatting to the data range (with Screenupdating set to false).

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

If bold is the only FontStyle that you want and your matrix just has values of TRUE and FALSE, then just keep the 2 lines of code that apply bold formatting, searching on the value of "TRUE" instead of "bold". Alternatively, additional or more complex formats can be easily specified in the replacement formats.

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

#7

It is not possible. However, you have set a bounty and spent some points so I can give some related tips. So to save code you could arrange your formats into VBA Styles.

这不可能。但是，你已经设定了赏金并花了一些积分，所以我可以给出一些相关的提示。因此，为了保存代码，您可以将格式安排到VBA样式中。

So you create a style once and then it is a one-liner to set a range. That should save some time. Here is some sample code.

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

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

Also for speed set Application.ScreenUpdating = False for the duration of the sheet writing/formatting. You could use a Class to help manage this using a RAII pattern.

对于表格写入/格式化期间的速度设置Application.ScreenUpdating = False也是如此。您可以使用类来帮助使用RAII模式进行管理。