[已解决]求：进度滚动条 代码？

fxgg72

如题，见附件。
谢谢各位大侠老师的帮助！



求：进度滚动条 代码？.zip (2.15 KB, 下载次数: 7)

2015-7-5 09:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

baksy

2015-7-5 11:50

附件

跳转到最佳答案楼层

wp8680

2007以上版本自带有。用F列取得百分比，然后用2007 以上版本才有的条件格式数据条，就OK

thinkersky

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 4 Or Target.Column = 5 Then
        Dim bf
        k = 0
        For Each pi In ActiveSheet.Shapes
            If pi.Top = Target.Top Then
                pi.Select
                k = 1
                Exit For
            End If
        Next
        bf = Cells(Target.Row, 5) / Cells(Target.Row, 4)
        If k = 0 Then
            ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Cells(Target.Row, 6).Left, Target.Top, Cells(Target.Row, 6).Width * bf, _
                Cells(Target.Row, 6).Height).Select
        Else
            Selection.Width = Cells(Target.Row, 6).Width * bf
        End If
        Cells(Target.Row, 6) = Format(bf, "0.00%")
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 176, 240)
            .Transparency = 0.8
            .Solid
        End With
        With Selection.ShapeRange.TextFrame2
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorNone
            .WordWrap = msoFalse
        End With
    End If
End Sub

wp8680

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim i%, c%, X%, L As Shape, k%
   
3.     If Intersect(Target, Range("d:e")) Is Nothing Then Exit Sub
   
4.     If Target.Row < 5 Then Exit Sub
   
5.     For Each L In ActiveSheet.Shapes
   
6.         If Left(L.Name, 4) = "Line" Then L.Delete
   
7.     Next L
   
8.     For i = 5 To Range("d" & Cells.Rows.Count).End(xlUp).Row
   
9.         c = Range("f" & i).Width
   
10.         X = c * (Range("e" & i) / Range("d" & i))
    
11.         ActiveSheet.Shapes.AddLine(282#, 192#, 363#, 192#).Select
    
12.         Selection.ShapeRange.Line.Weight = Range("f5").Height * 0.6
    
13.         Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
14.         Selection.Left = Range("f" & i).Left
    
15.         Selection.Top = Range("f" & i).Top + Range("f" & i).Height / 2
    
16.         Selection.Width = X
    
17.     Next i
    
18.     ActiveCell.Activate
    
19. End Sub

复制代码

wp8680

求：进度滚动条 代码？.rar (8.13 KB, 下载次数: 4)

2015-7-5 10:20 上传

点击文件名下载附件

baksy

附件

fxgg72

wp8680 发表于 2015-7-5 10:20

老师：这个代码我新建了一个模块复制进去，工作表里面输入数据没反应啊？
怎么用？
谢谢老师！

fxgg72

thinkersky 发表于 2015-7-5 10:19
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 4 Or Target.Column = 5 T ...

老师您好！
这个代码是能用，但在输入数据时老是提示代码错误。
但结束后，计算结果却又是对的。
老师能再看看么？
谢谢！

thinkersky

fxgg72 发表于 2015-7-5 17:32
老师您好！
这个代码是能用，但在输入数据时老是提示代码错误。
但结束后，计算结果却又是对的。

前面加一句
on error resume next

fxgg72

thinkersky 发表于 2015-7-5 10:19
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 4 Or Target.Column = 5 T ...