[已解决]求助一个画线的代码

dfzc

附件里有说明，请老师给解决一个画线的代码，谢谢！
Book1.zip (11.98 KB, 下载次数: 24)

2014-5-16 15:53 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-16 17:00

1. Sub Macro1()
   
2. Dim w(1 To 20000), rng1 As Range, rng2 As Range
   
3. For Each m In ActiveSheet.Shapes
   
4.     If m.Type <> 8 Then m.Delete
   
5. Next
   
6. For Each m In [o3:x152].SpecialCells(xlCellTypeConstants, 2)
   
7.     s = s + 1: w(s) = m.Address
   
8. Next
   
9. For i = 2 To s
   
10.     Set rng1 = Range(w(i - 1))
    
11.     Set rng2 = Range(w(i))
    
12.     x1 = rng1.Left + rng1.Width / 2
    
13.     y1 = rng1.Top + rng1.Height / 2
    
14.     x2 = rng2.Left + rng2.Width / 2
    
15.     y2 = rng2.Top + rng2.Height / 2
    
16.     ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    
17. Next
    
18. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub demo()
   
2.     Dim i&, j&
   
3.     Dim rg1L&, rg1T&, rg2T&, rg2L&
   
4.     Dim rgTop As Range, rgDown As Range
   
5.     On Error Resume Next
   
6.     ActiveSheet.DrawingObjects.Delete
   
7.     For i = 3 To Cells(Rows.Count, "j").End(xlUp).Row - 1
   
8.         Set rgTop = Cells(i, "o").Offset(, Cells(i, "j").Value)
   
9.         Set rgDown = Cells(i + 1, "o").Offset(, Cells(i + 1, "j").Value)
   
10.         rg1L = rgTop.Left
    
11.         rg1T = rgTop.Top
    
12.         rg2L = rgDown.Left
    
13.         rg2T = rgDown.Top
    
14.         ActiveSheet.Shapes.AddConnector msoConnectorStraight, rg1L, rg1T, rg2L, rg2T
    
15.     Next
    
16. 
    
17.     With ActiveSheet.DrawingObjects
    
18.         With .ShapeRange.Line
    
19.             .Visible = msoTrue
    
20.             .ForeColor.RGB = RGB(255, 0, 0)
    
21.         End With
    
22.     End With
    
23. End Sub

复制代码

hwc2ycy

1. Sub demo()
   
2.     Dim i&, j&
   
3.     Dim rg1L&, rg1T&, rg2T&, rg2L&
   
4.     Dim rgTop As Range, rgDown As Range
   
5.     On Error Resume Next
   
6.     Application.ScreenUpdating = False
   
7.     '清空原有线条
   
8.     ActiveSheet.DrawingObjects.Delete
   
9.     '生成连接线
   
10.     '单元格的左下角与下一个单元格的左上角连线
    
11.     For i = 3 To Cells(Rows.Count, "j").End(xlUp).Row - 1
    
12.         Set rgTop = Cells(i, "o").Offset(, Cells(i, "j").Value)
    
13.         Set rgDown = Cells(i + 1, "o").Offset(, Cells(i + 1, "j").Value)
    
14.         rg1L = rgTop.Left
    
15.         rg1T = rgTop.Top
    
16.         rg2L = rgDown.Left
    
17.         rg2T = rgDown.Top
    
18.         ActiveSheet.Shapes.AddConnector msoConnectorStraight, rg1L, rg1T, rg2L, rg2T
    
19.     Next
    
20.     '设置连接线颜色：红色
    
21.     With ActiveSheet.DrawingObjects
    
22.         With .ShapeRange.Line
    
23.             .Visible = msoTrue
    
24.             .ForeColor.RGB = RGB(255, 0, 0)
    
25.         End With
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "画线完成"
    
29. End Sub
    

复制代码

dfzc

可画完线怎么是这个样子呢，怎么修改老师

dsmch

1. Sub Macro1()
   
2. Dim w(1 To 20000), rng1 As Range, rng2 As Range
   
3. For Each m In ActiveSheet.Shapes
   
4.     If m.Type <> 8 Then m.Delete
   
5. Next
   
6. For Each m In [o3:x152].SpecialCells(xlCellTypeConstants, 2)
   
7.     s = s + 1: w(s) = m.Address
   
8. Next
   
9. For i = 2 To s
   
10.     Set rng1 = Range(w(i - 1))
    
11.     Set rng2 = Range(w(i))
    
12.     x1 = rng1.Left + rng1.Width / 2
    
13.     y1 = rng1.Top + rng1.Height / 2
    
14.     x2 = rng2.Left + rng2.Width / 2
    
15.     y2 = rng2.Top + rng2.Height / 2
    
16.     ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    
17. Next
    
18. End Sub
    

复制代码

dsmch

………………

hwc2ycy

不知道楼主怎么用的，我这是正常的。
另外，如果按5楼的中心位置画线可能更好看。

dfzc

谢谢，就这样了，很好！

02761752696

谢谢分享