如何在工作表自动画线连接两个给定的(数据)单元格?

q407

我就是火风 发表于 2011-12-12 01:45
自动连线，乐彩网中维多利亚做过，可惜她录制的录像已损坏，不过也通过宏制做的

1. <div class="blockcode"><blockquote>
   
2. Sub add()
   
3. Sheet1.Unprotect "123456"
   
4. Dim K, K1, I As Integer
   
5. Dim A, B, C, D As Single
   
6. For K = 4 To Sheet1.[a65536].End(xlUp).Row
   
7.   If Cells(K, 39) = "" Then '百位
   
8.         For I = 6 To 15
   
9.             If Cells(K, I) <> "" Then
   
10.                 C = Cells(K, I).Column
    
11.                 D = Cells(K, I).Row
    
12.                 C = ((C - 5) * 20 + 110) * 0.75
    
13.                 D = (D - 3) * 15 + 52.5
    
14.             End If
    
15.         Next
    
16.       
    
17.         If K <> 4 Then '来取得起点
    
18.          K1 = K - 1
    
19.          For I = 6 To 15
    
20.             If Cells(K1, I) <> "" Then
    
21.                 A = Cells(K1, I).Column
    
22.                 B = Cells(K1, I).Row
    
23.                 A = ((A - 5) * 20 + 110) * 0.75
    
24.                 B = (B - 3) * 15 + 52.5
    
25.             End If
    
26.         Next
    
27.         End If
    
28.       
    
29.         Sheet1.Shapes.AddLine(A, B, C, D).Select '坐标(A=?,B=列高1 ,C=?,D=列高2),像数转高度公式:像数*0.75
    
30.         Selection.ShapeRange.Line.Weight = 1.5 '粗细
    
31.         Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 '颜色
    
32.         A = 0
    
33.         B = 0
    
34.         C = 0
    
35.         D = 0
    
36.    
    
37.         
    
38. '********************************************十位
    
39.         For I = 17 To 26
    
40.             If Cells(K, I) <> "" Then
    
41.                 C = Cells(K, I).Column
    
42.                 D = Cells(K, I).Row
    
43.                 C = ((C - 16) * 20 + 320) * 0.75
    
44.                 D = (D - 3) * 15 + 52.5
    
45.             End If
    
46.         Next
    
47.       
    
48.         If K <> 4 Then '来取得起点
    
49.          K1 = K - 1
    
50.          For I = 17 To 26
    
51.             If Cells(K1, I) <> "" Then
    
52.                 A = Cells(K1, I).Column
    
53.                 B = Cells(K1, I).Row
    
54.                 A = ((A - 16) * 20 + 320) * 0.75
    
55.                 B = (B - 3) * 15 + 52.5
    
56.             End If
    
57.         Next
    
58.         End If
    
59.       
    
60.         Sheet1.Shapes.AddLine(A, B, C, D).Select '坐标(A=?,B=列高1 ,C=?,D=列高2),像数转高度公式:像数*0.75
    
61.         Selection.ShapeRange.Line.Weight = 1.5 '粗细
    
62.         Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 '颜色
    
63.         A = 0
    
64.         B = 0
    
65.         C = 0
    
66.         D = 0
    
67.      
    
68.         
    
69. '******************************************个位
    
70.         For I = 28 To 37
    
71.             If Cells(K, I) <> "" Then
    
72.                 C = Cells(K, I).Column
    
73.                 D = Cells(K, I).Row
    
74.                 C = ((C - 27) * 20 + 530) * 0.75
    
75.                 D = (D - 3) * 15 + 52.5
    
76.             End If
    
77.         Next
    
78.       
    
79.         If K <> 4 Then '来取得起点
    
80.          K1 = K - 1
    
81.          For I = 28 To 37
    
82.             If Cells(K1, I) <> "" Then
    
83.                 A = Cells(K1, I).Column
    
84.                 B = Cells(K1, I).Row
    
85.                 A = ((A - 27) * 20 + 530) * 0.75
    
86.                 B = (B - 3) * 15 + 52.5
    
87.             End If
    
88.         Next
    
89.         End If
    
90.       
    
91.         Sheet1.Shapes.AddLine(A, B, C, D).Select '坐标(A=?,B=列高1 ,C=?,D=列高2),像数转高度公式:像数*0.75
    
92.         Selection.ShapeRange.Line.Weight = 1.5 '粗细
    
93.         Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 '颜色
    
94.         A = 0
    
95.         B = 0
    
96.         C = 0
    
97.         D = 0
    
98.       
    
99.         Cells(K, 39) = 1
    
100.     End If
     
101. Next
     
102. Range("A1").Select
     
103. Sheet1.Protect Password:="123456"
     
104. End Sub

复制代码

   
  

菊花大哥的下载不了了，谢谢层主提示，找到了

111019180703acf6ec866968fb.rar (610.45 KB, 下载次数: 81)

2020-11-10 01:43 上传

点击文件名下载附件
1