如何在不使用条件格式的情况下使用 VBA 将符号/图标格式化为单元格

How can I use VBA to format Symbols / Icons into cells without using conditional formatting

提问by user2405738

I am using VBA code to place conditional formatting to cover values in a large table, I use 2 formulae per cell to determine which of the 3 symbols to use. I need to check the value of each cell with a different cell depending on the column and therefore as far as I understamd, I have to place my conditional formatting rule on each cell individually to ensure the formula is correct in each. This is because conditional formatting cannot take relative addresses, you have to give it the exact address of each cell ... correct?

我正在使用 VBA 代码放置条件格式以覆盖大表中的值，我在每个单元格中使用 2 个公式来确定要使用 3 个符号中的哪一个。我需要根据列用不同的单元格检查每个单元格的值，因此据我所知，我必须将条件格式规则分别放在每个单元格上，以确保每个单元格中的公式都是正确的。这是因为条件格式不能采用相对地址，你必须给它每个单元格的确切地址......对吗？

The large number of conditional formatting instances is slowing my computer to a huge extent.

大量的条件格式实例在很大程度上降低了我的计算机速度。

Is it possible to place symbols used by conditional formatting, into a cell, without using conditional formatting?

是否可以将条件格式使用的符号放入单元格中，而不使用条件格式？

Perhaps somewhat like an image, but whilst retaining the cell value underneath, as can be done using conditional formatting.

也许有点像图像，但同时保留下面的单元格值，可以使用条件格式来完成。

Below I have given the code I use to put the conditional formatting in place. Any help is very much appreciated!!

下面我给出了我用来放置条件格式的代码。很感谢任何形式的帮助！！

    Dim AIs As Range
    Dim rng As Range
    Dim cl As Range

    Set AIs = ActiveSheet.Range("Table")
    For Each cl In AIs.Columns
        For Each rng In cl.Cells

        rng.FormatConditions.AddIconSetCondition
        rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
        With rng.FormatConditions(1)
            .ReverseOrder = False
            .ShowIconOnly = True
            .IconSet = ActiveWorkbook.IconSets(xl3Symbols2)
        End With

         With rng.FormatConditions(1).IconCriteria(1)
            .Icon = xlIconYellowExclamationSymbol
        End With
        With rng.FormatConditions(1).IconCriteria(2)
            .Icon = xlIconRedCross

            .Type = xlConditionValueFormula
            .Value = "=IF(VALUE(LEFT(" & rng.Parent.Cells(5, rng.Column).Address & _
                  ";1)=0;1;6)"

            .Operator = 7
        End With
        With rng.FormatConditions(1).IconCriteria(3)
            .Icon = xlIconGreenCheck

            .Type = xlConditionValueFormula
            .Value = "=IF(VALUE(LEFT(" & rng.Address & ";1))<=VALUE(LEFT(" & _
                  rng.Parent.Cells(5, rng.Column).Address & ";1));1;6)"

            .Operator = 7
        End With
        Next rng
    Next cl

采纳答案by SeanC

Adding a shape directly to a cell:

直接向单元格添加形状：

Dim cLeft As Single
Dim cTop As Single

cLeft = rng.Left
cTop = rng.Top

with AIs.Shapes.AddShape(msoShapeOval, cLeft, cTop, 12, 12)
    .ForeColor.RGB = RGB(255, 0, 0)
    'Other properties can be found at
    'http://msdn.microsoft.com/en-us/library/office/bb251480%28v=office.12%29.aspx
end with

you may want to adjust cTop and cLeft, and the width/height to position the circle as you wish

您可能需要调整 cTop 和 cLeft，以及根据需要调整圆的宽度/高度

回答by user2405738

Final code:

最终代码：

     Set AIs = ActiveSheet.Range("Table")
     For Each cl In AIs.Columns
        For Each rng In cl.Cells

            'Shapes  - GRADE MASK


            cLeft = rng.Left + 5 - (rng.ColumnWidth / 2)
            cTop = rng.Top + (rng.RowHeight / 2 - 5)

            If Not rng = "" And rng.ColumnWidth = 3 And rng.RowHeight > 12 Then

            If rng.Parent.Cells(5, rng.Column) = 0 Then
                With wks.Shapes.AddShape(msoShapeOval, cLeft, cTop, 10, 10)
                    .Fill.ForeColor.RGB = RGB(255, 0, 0)
                End With
            End If
            If CInt(Left(rng, 1)) >= CInt(Left(rng.Parent.Cells(5, rng.Column), 1)) And _
             Not rng.Parent.Cells(5, rng.Column) = 0 Then
                With wks.Shapes.AddShape(msoShapeOval, cLeft, cTop, 10, 10)
                    .Fill.ForeColor.RGB = RGB(0, 255, 0)
                End With
            End If
            If CInt(Left(rng, 1)) < CInt(Left(rng.Parent.Cells(5, rng.Column), 1)) Then
                With wks.Shapes.AddShape(msoShapeOval, cLeft, cTop, 10, 10)
                    .Fill.ForeColor.RGB = RGB(255, 204, 0)
                End With
            End If
            End If
        Next rng
    Next cl

    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
       userinterfaceonly:=True

Then every time I call a macro, I remove all the shapes on the worksheet, perform my macro and then call this again, in the if statements above there are checks to see how big the column width and row height are and a shape is only inserted if the cell is "visible"

然后每次我调用宏时，我都会删除工作表上的所有形状，执行我的宏然后再次调用它，在上面的 if 语句中，检查列宽和行高有多大，形状只有如果单元格“可见”，则插入

In my program, for other reasons outside this subroutine I cannot hide my rows or columns but instead reduce their height or width to be just big enough to display the cell borders.

在我的程序中，由于这个子程序之外的其他原因，我无法隐藏我的行或列，而是将它们的高度或宽度减小到足以显示单元格边框的大小。