[已解决]怎样自动连线相同的单元格

jsxrjhz

想在FA-GO列点击任意单元格，自动连线相同的单元格，如附件。
附件中我是用手工划的，很费时间
怎样能自动链接，请知道的教我一下，万分感谢！！！
手绘效果图.rar (101.84 KB, 下载次数: 20)

2015-5-7 11:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-5-8 09:19

这样总对了吧。

跳转到最佳答案楼层

grf1973

1. Sub 宏1()
   
2.     Application.ScreenUpdating = False
   
3.     Dim rng1 As Range, rng2 As Range
   
4.     On Error Resume Next
   
5.     For Each shp In ActiveSheet.Shapes
   
6.         If InStr(shp.Name, "Connector") > 0 Then shp.Delete
   
7.         If InStr(shp.Name, "Line") > 0 Then shp.Delete
   
8.     Next
   
9.     Range("fa1:go120").Interior.ColorIndex = -4142
   
10.     Range("fa1:go120").Font.ColorIndex = 5
    
11.     For j = 197 To 157 Step -2
    
12.         For i = 1 To 120
    
13.             If Cells(i, j) = ActiveCell Then
    
14.                 n = n + 1
    
15.                 Cells(i, j).Interior.ColorIndex = 7
    
16.                 Cells(i, j).Font.Color = vbWhite
    
17.                 If n = 1 Then
    
18.                     Set rng1 = Cells(i, j)
    
19.                 Else
    
20.                     Set rng2 = Cells(i, j)
    
21.                     Call AddArrow(rng1, rng2)
    
22.                     Set rng1 = Cells(i, j)
    
23.                 End If
    
24.             End If
    
25.         Next
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    
29. 
    
30. Sub AddArrow(rng1 As Range, rng2 As Range)      'rng1-->rng2，画箭头
    
31.     a1 = rng1.Left + rng1.Width / 2: b1 = rng1.Top + rng1.Height / 2
    
32.     a2 = rng2.Left + rng2.Width / 2: b2 = rng2.Top + rng2.Height / 2
    
33.     ActiveSheet.Shapes.AddConnector(msoConnectorStraight, a1, b1, a2, b2).Select
    
34.     Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
    
35. End Sub
    

复制代码

jsxrjhz

grf1973 发表于 2015-5-7 14:20

刚打开指向“93”的效果是我想要的效果，但按钮后就不是的了，连线的走向都往表右一边斜。您看您上传的附件里是不是哪里少了些什么、、、

jsxrjhz

按钮选单元格很满意，能否在新连线时，同时去掉老连线，只显示新连线？
汗啊，不懂啊、、、、

grf1973

原来就是去掉老连线，再画新连线的。干脆小改了一下，在限定范围内点击单元格（奇数列），会自动生成连线。

grf1973

这样总对了吧。

jsxrjhz

对了，完全对了。谢谢大侠。
（问题还有，就是我只会用2003，在2003上运行不删除老连线，观察几次后，窗口尽是不相交的斜线，看到你的动画，才知道版本不一样，拿到别人的电脑上，2013一切OK。这正是时不我待，逼我升级啊）
谢谢，真心谢谢。

jsxrjhz

用2003版本运行是这样：
http://www.excelpx.com/forum.php?mod=attachment&aid=MzYwMDM1fDBhZTJiNmIzNDczNzE4ZjU3ODg1OWExYWNlMWUzNDZhfDE3MTQxNDY2OTU%3D&request=yes&_f=.gif

zxh1124

grf1973 发表于 2015-5-7 14:20

学习了