[已解决]VBA代码自动连线的修改（补上了附件）

无聊的疯子

整这个东西还得数学好才得行，我经常在里面算来算去的，就是要不得！！

夏之恋之夏

老大不好意思，最后个问题帮忙解决下，因为增加了4行，线条的头部乱掉了，我修改了2个代码，但是还是有问题，帮忙解决下，谢谢
Sub huax0304()
'画线
Dim n%, x%, x1, y1, x2, y2
Dim Myr%(1 To 16), nn%
For x = 2 To 17
    Myr(x - 1) = Cells(65536, x).End(xlUp).Row
Next x
nn = Application.Max(Myr)
n = 1
For x = 4 To nn
        aa = Cells(x, 1)
            If n > 1 Then
                x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa + 2).Width / 2: y2 = Cells(x, 1).Offset(0, aa + 2).Top + Cells(x, 1).Offset(0, aa + 2).Height / 2
                ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
                Selection.ShapeRange.Line.Weight = 1.5
                Selection.ShapeRange.Line.ForeColor.SchemeColor = 6    '粉红色
                x1 = x2: y1 = y2
                'n = 1
                GoTo 100
            Else
                x1 = Cells(x, 1).Offset(0, aa + 2).Left: y1 = Cells(x, 1).Offset(2, aa + 0).Top
                n = n + 1
            End If
100:
Next x
End Sub
Sub test()
'删除所有的线
For Each shp In ActiveSheet.Shapes
'MsgBox shp.Name
    If InStr(shp.Name, "Line") > 0 Then
     shp.Delete
    End If
Next
End Sub

修改了Else
                x1 = Cells(x, 1).Offset(0, aa + 2).Left: y1 = Cells(x, 1).Offset(2, aa + 0).Top
                n = n + 1

兰色幻想

把你增加了四行的文件传上来，不知道是怎么增加的

夏之恋之夏

1.rar (30.02 KB, 下载次数: 9)

2011-8-11 22:37 上传

点击文件名下载附件
附件已上传，谢谢！

兰色幻想

没看懂，你想要怎么样的效果呢，下面的数字超过了16所以线都连到外面了

夏之恋之夏

兰色幻想 发表于 2011-8-11 23:54
没看懂，你想要怎么样的效果呢，下面的数字超过了16所以线都连到外面了

线条应该从第6行开始画的，但是我这线条在第5行也有，能否去掉呢，谢谢！

夏之恋之夏

1.rar (31.86 KB, 下载次数: 35)

2011-8-13 16:02 上传

点击文件名下载附件

老大你看到了吗？第一个数字10上面有多余的线条，请问如何去掉，怎么修改VBA代码去掉，谢谢！

兰色幻想

For x = 6 To nn
        aa = Cells(x, 1)
            If n > 1 Then
                x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa + 2).Width / 2: y2 = Cells(x, 1).Offset(0, aa + 2).Top + Cells(x, 1).Offset(0, aa + 2).Height / 2
                ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
                Selection.ShapeRange.Line.Weight = 1.5
                Selection.ShapeRange.Line.ForeColor.SchemeColor = 6    '粉红色
                x1 = x2: y1 = y2
                'n = 1
                GoTo 100
            Else
                x1 = Cells(x, 1).Offset(0, aa + 2).Left: y1 = Cells(x - 1, 1).Offset(2, aa + 0).Top
                MsgBox Cells(x, 1).Offset(0, aa + 2).Address
                n = n + 1
            End If
100:
Next x
End Sub

夏之恋之夏

哦，谢谢了！