[已解决]求助：怎样用VBA实现单元格连线的问题？谢谢！(已解决，感谢 jkczfpb 版主)

喜欢学习编程

怎样用VBA实现单元格连线的问题？谢谢！

最佳答案

月排行榜 / 总排行榜

jkczfpb

2011-7-10 15:22

回复 喜欢学习编程 的帖子

单元格连线.rar (11.77 KB, 下载次数: 60)

2011-7-10 15:30 上传

点击文件名下载附件

1. 
   
2. 
   
3. 
   
4. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
5. Dim ARR As Variant
   
6. Dim I As Byte, B As Byte
   
7. Dim S1 As String, S2 As String, S3 As String, S4 As String
   
8.     If Target.Column > 1 Then Exit Sub
   
9.     ARR = VBA.Split(Target.Value, ",")
   
10.     If UBound(ARR) < 1 Then Exit Sub
    
11.     B = UBound(ARR)
    
12.     With Application
    
13.         .DisplayAlerts = False
    
14.         .EnableEvents = False
    
15.         .ScreenUpdating = False
    
16.     End With
    
17.         Range("F7:H13").Interior.ColorIndex = xlNone
    
18.         ActiveSheet.DrawingObjects.Delete
    
19.         For I = 0 To B
    
20.             With Range(ARR(I))
    
21.                 .Interior.ColorIndex = 10
    
22.                 ARR(I) = .Left + .Width / 2 & "," & .Top + .Height / 2
    
23.             End With
    
24.         Next
    
25.         For I = 1 To B
    
26.             S1 = VBA.Split(ARR(I - 1), ",")(0)
    
27.             S2 = VBA.Split(ARR(I - 1), ",")(1)
    
28.             S3 = VBA.Split(ARR(I), ",")(0)
    
29.             S4 = VBA.Split(ARR(I), ",")(1)
    
30.             With ActiveSheet.Shapes.AddLine(S1, S2, S3, S4).Line
    
31.                 .Weight = 2.25
    
32.                 .Visible = msoTrue
    
33.                 .Style = msoLineSingle
    
34.                 .ForeColor.SchemeColor = 3
    
35.                 .Visible = msoTrue
    
36.             End With
    
37.         Next
    
38.     With Application
    
39.         .DisplayAlerts = True
    
40.         .EnableEvents = True
    
41.         .ScreenUpdating = True
    
42.     End With
    
43. End Sub
    
44. 
    

复制代码

跳转到最佳答案楼层

无聊的疯子

回复 喜欢学习编程 的帖子

将你原来的代码放进

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

End Sub

事件中即可

jkczfpb

回复 喜欢学习编程 的帖子

单元格连线.rar (11.77 KB, 下载次数: 60)

2011-7-10 15:30 上传

点击文件名下载附件

1. 
   
2. 
   
3. 
   
4. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
5. Dim ARR As Variant
   
6. Dim I As Byte, B As Byte
   
7. Dim S1 As String, S2 As String, S3 As String, S4 As String
   
8.     If Target.Column > 1 Then Exit Sub
   
9.     ARR = VBA.Split(Target.Value, ",")
   
10.     If UBound(ARR) < 1 Then Exit Sub
    
11.     B = UBound(ARR)
    
12.     With Application
    
13.         .DisplayAlerts = False
    
14.         .EnableEvents = False
    
15.         .ScreenUpdating = False
    
16.     End With
    
17.         Range("F7:H13").Interior.ColorIndex = xlNone
    
18.         ActiveSheet.DrawingObjects.Delete
    
19.         For I = 0 To B
    
20.             With Range(ARR(I))
    
21.                 .Interior.ColorIndex = 10
    
22.                 ARR(I) = .Left + .Width / 2 & "," & .Top + .Height / 2
    
23.             End With
    
24.         Next
    
25.         For I = 1 To B
    
26.             S1 = VBA.Split(ARR(I - 1), ",")(0)
    
27.             S2 = VBA.Split(ARR(I - 1), ",")(1)
    
28.             S3 = VBA.Split(ARR(I), ",")(0)
    
29.             S4 = VBA.Split(ARR(I), ",")(1)
    
30.             With ActiveSheet.Shapes.AddLine(S1, S2, S3, S4).Line
    
31.                 .Weight = 2.25
    
32.                 .Visible = msoTrue
    
33.                 .Style = msoLineSingle
    
34.                 .ForeColor.SchemeColor = 3
    
35.                 .Visible = msoTrue
    
36.             End With
    
37.         Next
    
38.     With Application
    
39.         .DisplayAlerts = True
    
40.         .EnableEvents = True
    
41.         .ScreenUpdating = True
    
42.     End With
    
43. End Sub
    
44. 
    

复制代码

喜欢学习编程

感谢 jkczfpb 版主，是这个效果。还有另外改变一下，单元格标记的方式，看附件：

喜欢学习编程

ActiveSheet.DrawingObjects.Delete
这句代码把表格里所有按钮都清除掉了，而且看不懂它的意思，只知道它能实现什么功能！
该怎样换句代码不清除掉表格里的按钮呢？