Excel VBA循環通過一系列單元格以基於If語句插入形狀

我正在嘗試向單元格添加倒置的紅色三角形以指示性能下降。例如，當單元格B5小於0時，將倒置的紅色三角形插入單元格B3中。如果B5小於零，我已經設法將插入到B3的形狀，但是現在我需要爲單元格C3 DC5，D3 & D5，E3 & E5執行此操作，一直到列M，可能更多。不僅如此，我還需要爲我的電子表格中的更多行做更多的工作。如何讓我的宏循環遍歷每一行和一列，以便它檢查一個單元格是否小於零，然後它將向單元格（行，列）添加一個顛倒的紅色三角形？Excel VBA循環通過一系列單元格以基於If語句插入形狀

Sub Add_negative_Triangle() 


'Adds Red Triangle to a Cell to indicate a decrease when corresponding cell if of a certain value 

    Dim SSLeft As Double 
    Dim SSRight As Double 
    Dim SSTop As Double 
    Dim SSWidth As Double 
    Dim SSHeight As Double 
    Dim SS As Range, N As Long 
    Dim z As Integer 
    Dim shpIsoscelesTriangle As Shape 
    Set SS = Range("B3:M3") 
    z = 0 
    SSLeft = SS.Left 
    SSTop = SS.Top 
    SSHeight = SS.Height 
    SSWidth = SS.Width 



    If Range("B5:M5") <= z Then 
     ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, SSLeft, SSTop, 11, 13).Select 

    End If 


If Range("B5:M5") <= z Then 
With Selection.ShapeRange.Fill 
     .Visible = msoTrue 
     .ForeColor.RGB = RGB(205, 0, 0) 
     .Transparency = 0 
     .Solid 
End With 



              End If 

If Range("B5:M5") <= z Then 


With Selection.ShapeRange.Line 
     .Visible = msoTrue 
     .ForeColor.RGB = RGB(205, 0, 0) 
     .Transparency = 0 
    End With 
              End If 


Selection.ShapeRange.Rotation = 180 
Selection.ShapeRange.IncrementLeft 1.5 
Selection.ShapeRange.IncrementTop 1.5 





End Sub

來源

2017-02-15 OB2013

這將您的三角形狀添加到每一個細胞B5:M5在電池上面兩行具有負值。您可以將其應用於任何範圍（從第3行開始）。

Sub Add_negative_Triangle() 
    Dim ss As Range, shp As Shape 
    For Each ss In ActiveSheet.Range("B5:M5") 
     If ss.offset(-2).value < 0 Then 
      Set shp = ss.Parent.Shapes.AddShape(msoShapeIsoscelesTriangle, ss.Left, ss.Top, 11, 13) 
      With shp.Fill 
       .Visible = msoTrue 
       .ForeColor.RGB = RGB(205, 0, 0) 
       .Transparency = 0 
       .Solid 
      End With 
      With shp.line 
       .Visible = msoTrue 
       .ForeColor.RGB = RGB(205, 0, 0) 
       .Transparency = 0 
      End With 
      shp.Rotation = 180 
      shp.IncrementLeft 1.5 
      shp.IncrementTop 1.5 
     End If 
    Next 
End Sub

來源

2017-02-15 16:24:10

打我給它。花了我一段時間才發現ShapeRange導致了錯誤。 – SJR

@SJR最初的OP代碼只是近似的，我認爲... –

@ user3598756，是的，從第3行開始。我添加了詳細信息，謝謝。 –

試試這個

Sub Add_negative_Triangle() 

'Adds Red Triangle to a Cell to indicate a decrease when corresponding cell if of a certain value 

    Dim SSLeft As Double 
    Dim SSRight As Double 
    Dim SSTop As Double 
    Dim SSWidth As Double 
    Dim SSHeight As Double 
    Dim SS As Range, N As Long 
    Dim z As Integer 
    Dim shpIsoscelesTriangle As Shape 
    Dim r As Range 
    Dim s As Shape 

    Set SS = Range("B3:M3") 
    z = 0 

    For Each r In SS 
     SSLeft = r.Left 
     SSTop = r.Top 
     SSHeight = r.Height 
     SSWidth = r.Width 

     If r.Offset(2) <= z Then 
      Set s = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, SSLeft, SSTop, 11, 13) 
      With s.Fill 
       .Visible = msoTrue 
       .ForeColor.RGB = RGB(205, 0, 0) 
       .Transparency = 0 
       .Solid 
      End With 
      With s.Line 
       .Visible = msoTrue 
       .ForeColor.RGB = RGB(205, 0, 0) 
       .Transparency = 0 
      End With 
      s.Rotation = 180 
      s.IncrementLeft 1.5 
      s.IncrementTop 1.5 
     End If 
    Next r 

End Sub

來源

2017-02-15 16:30:50 SJR

Excel VBA循環通過一系列單元格以基於If語句插入形狀

回答

相關問題