VBA在EXCEL中创建图形线条

Private Sub ClearPreviousLines()
    Const LINE_FLAG As String = "#LINE#"
      
    Dim myLine As Shape
      
    For Each myLine In ActiveSheet.Shapes
        If InStr(1, myLine.Name, LINE_FLAG, vbTextCompare) > 0 Then
            myLine.Delete
        End If
    Next
      
End Sub

    
Private Sub MarkCurrentProgress()
      
    Const LINE_FLAG As String = "#LINE#"
    Const RNG_MAIN_PROG As String = "B5"
    Const COL_PROGRESS As Integer = 10
    Const COLS_PROGRESS As Integer = 10
  
    Dim r As Long
    Dim x As Integer, y As Integer, h As Integer
      
      
    ‘Mark each step progress
    For r = 1 To ActiveSheet.UsedRange.Rows.Count
        strPercent = CStr(Cells(r, COL_PROGRESS).Value)
        If strPercent <> "" Then
            If IsNumeric(strPercent) Then
   
                With Cells(r, COL_PROGRESS)
                    x = .Left + (Cells(r, COL_PROGRESS + COLS_PROGRESS).Left - .Left) * .Value
                    y = .Top
                    h = .Height
                End With
                          
                ActiveSheet.Shapes.AddLine(x, y, x, y + h).Name = LINE_FLAG & CStr(r)
                          
            End If
        End If
    Next r
      
    ‘Mark main progress
    Range(RNG_MAIN_PROG).Select
    With Selection
        x = .Left + .Width * Selection(1, 1).Value
        y = .Top
        h = .Height
    End With
    ActiveSheet.Shapes.AddLine(x, y, x, y + h).Name = LINE_FLAG & "Main"
  
End Sub