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

夏之恋之夏

画线0305.rar (15.8 KB, 下载次数: 62)

2011-8-8 19:14 上传

点击文件名下载附件 最近在精英论坛上下载了个用VBA实现自动连线的小程序，想把里面的数字修改下，请问如何修改，谢谢！
原图如下：
想修改成如下效果
去掉0，增加11-16，但是功能要保留，增加个删除按钮，代码里面有写好，不知道如何修改，代码如下
Sub huax0304()
'画线
Dim n%, x%, x1, y1, x2, y2
Dim Myr%(1 To 10), nn%
For x = 2 To 11
    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: y2 = Cells(x, 1).Offset(0, aa + 2).Top
                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(0, aa + 2).Top
                n = n + 1
            End If
100:
Next x
End Sub
Sub test()
'删除所有的线
For Each shp In ActiveSheet.Shapes
'MsgBox shp.Name
    If shp.Name <> "Button 206" And shp.Name <> "AutoShape 207" Then
    shp.Delete
    End If
Next
End Sub
请帮忙解决，谢谢！
忘记上传了不好意思！（补上了！）

最佳答案

月排行榜 / 总排行榜

兰色幻想

2011-8-11 18:34

晕，看了半天，才发现是S列太宽的原因，每一列都是根据它后面一列的列宽推算出来的，你要求是中线，S一列除以2的列宽也是很宽的，所以会出现，两种解决办法
第一种把S列宽调整成和前面一样的列宽，
第二种改一下代码：
x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa + 2).Width / 2
改成
x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa +1).Width / 2

跳转到最佳答案楼层

兰色幻想

在哪下载的，给个链接，或你上传文件

夏之恋之夏

没人帮忙修改吗?

兰色幻想

Dim Myr%(1 To 11), nn%  11改成16
For x = 2 To 12   '12改成17

夏之恋之夏

兰色幻想 发表于 2011-8-8 21:01
Dim Myr%(1 To 11), nn%  11改成16
For x = 2 To 12   '12改成17

改完之后画出的线不是对应数字了，有错误，能修改下附件吗？

夏之恋之夏

1.rar (18.45 KB, 下载次数: 14)

2011-8-9 21:36 上传

点击文件名下载附件
补充一下，现在还有几个问题
1、A列中输入0至9的数字能显示蓝底，9以上的数字不能显示蓝底
2、连线的线条都在单元格的右上角，能否在单元格中间呢
3、点击删线后按钮消失了，是不是代码有问题
感谢高手帮忙解决，谢谢了！
PS：把数字0删除后划线，全部线条会往后移动一格，什么原因呢，谢谢！

VBA代码如下：
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: y2 = Cells(x, 1).Offset(0, aa + 2).Top
                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(0, aa + 2).Top
                n = n + 1
            End If
100:
Next x
End Sub
Sub test()
'删除所有的线
For Each shp In ActiveSheet.Shapes
'MsgBox shp.Name
    If shp.Name <> "Button 206" And shp.Name <> "AutoShape 207" Then
    shp.Delete
    End If
Next
End Sub

兰色幻想

第一个问题，填充是由条件格式的条件决定的，不符合条件肯定不会设置兰底。
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(0, aa + 2).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

夏之恋之夏

11.rar (18.75 KB, 下载次数: 40)

2011-8-11 18:01 上传

点击文件名下载附件

老大再帮忙看看，是不是代码有问题啊，划线只能到数字15,数字16那格过不去，是什么原因啊！
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(0, aa + 2).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
谢谢了！

兰色幻想

晕，看了半天，才发现是S列太宽的原因，每一列都是根据它后面一列的列宽推算出来的，你要求是中线，S一列除以2的列宽也是很宽的，所以会出现，两种解决办法
第一种把S列宽调整成和前面一样的列宽，
第二种改一下代码：
x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa + 2).Width / 2
改成
x2 = Cells(x, 1).Offset(0, aa + 2).Left - Cells(x, 1).Offset(0, aa +1).Width / 2

夏之恋之夏

非常感谢！谢谢！