分享一个自己CAD表格转EXCEL源程序

qwh923820

本人水平有限，大部分CAD编程技能从明经论坛学习的，刚刚写了个CAD表格转EXCEL源程序，分享大家，一起进步！
程序说明：把PT1和pT2范围内的文字转换成数组，输出到excel表格1里面，所以一定要打开EXCEL才行。具体用法可以根据自己的需求修改。

2. Option Explicit
   
3. 
   
4. Public Sub Cad表格转Excel()
   
5. Dim objEntArr() As Object, i As Long
   
6. Dim objSset As AcadSelectionSet
   
7. Dim Y As AcadSelectionSet
   
8. Dim pt1(2) As Double, pt2(2) As Double, na$
   
9. Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k
   
10. 
    
11. 'pt1,pt2是表格的位置，左下，右上
    
12. pt1(0) = -1500
    
13. pt1(1) = -1500
    
14. pt1(2) = 0
    
15. pt2(0) = 43200
    
16. pt2(1) = 43200
    
17. pt2(2) = 0
    
18. na = "QQQ"
    
19. On Error Resume Next
    
20. If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    
21.     Set Y = ThisDrawing.SelectionSets.Item(na)
    
22.     Y.Delete
    
23. End If
    
24. Set Y = ThisDrawing.SelectionSets.Add(na)
    
25.       Dim gpCode(0) As Integer
    
26.       Dim dataValue(0) As Variant
    
27.       gpCode(0) = 0
    
28.       dataValue(0) = "text,mtext"
    
29.       Dim groupCode As Variant, dataCode As Variant
    
30.       groupCode = gpCode
    
31.       dataCode = dataValue
    
32. Y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    
33.     For i = 0 To Y.Count - 1
    
34.         A(i + 1, 1) = i
    
35.         A(i + 1, 2) = Y.Item(i).TextString
    
36.         p = Y.Item(i).InsertionPoint
    
37.         A(i + 1, 3) = p(0)
    
38.         A(i + 1, 4) = p(1)
    
39.     Next i
    
40. Y.Delete
    
41. k = 50     'k是过滤间隙
    
42. B = 过滤数组(A, 4, k)
    
43. C = 过滤数组(A, 3, k + 5)
    
44. ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
    
45. For i = 1 To UBound(A)
    
46.     If A(i, 2) = "" Then Exit For
    
47.     For n = 0 To UBound(B)
    
48.         '行的位置
    
49.         If Abs(B(n) - A(i, 4)) < k Then
    
50.             Exit For
    
51.         End If
    
52.     Next n
    
53.     For m = 0 To UBound(B)
    
54.         '列的位置
    
55.         If Abs(C(m) - A(i, 3)) < k Then
    
56.             Exit For
    
57.         End If
    
58.     Next m
    
59.     D(UBound(B) + 1 - n, 1 + m) = A(i, 2)
    
60. Next i
    
61. Dim exlh As Object
    
62. Set exlh = GetObject(, "excel.application")
    
63. With exlh
    
64.     .workbooks(1).worksheets(1).Select
    
65.     .cells(1, 1).resize(UBound(B) + 1, UBound(C) + 1) = D
    
66. End With
    
67. End Sub
    
68. 
    
69. Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant
    
70. 'A是数组，n是过滤的列，k是过滤的间隙
    
71. Dim B(), i, j, p, m
    
72. j = 0
    
73. ReDim B(0)
    
74. B(0) = A(1, n)
    
75. For i = 2 To UBound(A)
    
76.     m = 0
    
77.     If A(i, n) = "" Then Exit For
    
78.     For p = 0 To j
    
79.         If Abs(A(i, n) - B(p)) < k Then
    
80.             m = 1
    
81.             Exit For
    
82.         End If
    
83.     Next p
    
84.     If m = 0 Then
    
85.         j = j + 1
    
86.         ReDim Preserve B(j)
    
87.         B(j) = A(i, n)
    
88.     End If
    
89. Next i
    
90. 过滤数组 = 冒泡排序(B)
    
91. 
    
92. End Function
    
93. Function 冒泡排序(ByVal A) As Variant
    
94. '从小到大
    
95. Dim i, j, n
    
96. For i = 0 To UBound(A) - 1
    
97.     For j = 0 To UBound(A) - 1 - i
    
98.         If A(j) > A(j + 1) Then
    
99.             n = A(j + 1)
    
100.             A(j + 1) = A(j)
     
101.             A(j) = n
     
102.         End If
     
103.     Next j
     
104. Next i
     
105. 冒泡排序 = A
     
106. End Function
     
107. 
     

Option Explicit<br /> <br /> Public Sub Cad表格转Excel()<br /> Dim objEntArr() As Object, i As Long<br /> Dim objSset As AcadSelectionSet<br /> Dim Y As AcadSelectionSet<br /> Dim pt1(2) As Double, pt2(2) As Double, na$<br /> Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k<br /> <br /> 'pt1,pt2是表格的位置，左下，右上<br /> pt1(0) = -1500<br /> pt1(1) = -1500<br /> pt1(2) = 0<br /> pt2(0) = 43200<br /> pt2(1) = 43200<br /> pt2(2) = 0<br /> na = "QQQ"<br /> On Error Resume Next<br /> If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then<br />     Set Y = ThisDrawing.SelectionSets.Item(na)<br />     Y.Delete<br /> End If<br /> Set Y = ThisDrawing.SelectionSets.Add(na)<br />       Dim gpCode(0) As Integer<br />       Dim dataValue(0) As Variant<br />       gpCode(0) = 0<br />       dataValue(0) = "text,mtext"<br />       Dim groupCode As Variant, dataCode As Variant<br />       groupCode = gpCode<br />       dataCode = dataValue<br /> Y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode<br />     For i = 0 To Y.Count - 1<br />         A(i + 1, 1) = i<br />         A(i + 1, 2) = Y.Item(i).TextString<br />         p = Y.Item(i).InsertionPoint<br />         A(i + 1, 3) = p(0)<br />         A(i + 1, 4) = p(1)<br />     Next i<br /> Y.Delete<br /> k = 50     'k是过滤间隙<br /> B = 过滤数组(A, 4, k)<br /> C = 过滤数组(A, 3, k + 5)<br /> ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)<br /> For i = 1 To UBound(A)<br />     If A(i, 2) = "" Then Exit For<br />     For n = 0 To UBound(B)<br />         '行的位置<br />         If Abs(B(n) - A(i, 4)) < k Then<br />             Exit For<br />         End If<br />     Next n<br />     For m = 0 To UBound(B)<br />         '列的位置<br />         If Abs(C(m) - A(i, 3)) < k Then<br />             Exit For<br />         End If<br />     Next m<br />     D(UBound(B) + 1 - n, 1 + m) = A(i, 2)<br /> Next i<br /> Dim exlh As Object<br /> Set exlh = GetObject(, "excel.application")<br /> With exlh<br />     .workbooks(1).worksheets(1).Select<br />     .cells(1, 1).resize(UBound(B) + 1, UBound(C) + 1) = D<br /> End With<br /> End Sub<br /> <br /> Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant<br /> 'A是数组，n是过滤的列，k是过滤的间隙<br /> Dim B(), i, j, p, m<br /> j = 0<br /> ReDim B(0)<br /> B(0) = A(1, n)<br /> For i = 2 To UBound(A)<br />     m = 0<br />     If A(i, n) = "" Then Exit For<br />     For p = 0 To j<br />         If Abs(A(i, n) - B(p)) < k Then<br />             m = 1<br />             Exit For<br />         End If<br />     Next p<br />     If m = 0 Then<br />         j = j + 1<br />         ReDim Preserve B(j)<br />         B(j) = A(i, n)<br />     End If<br /> Next i<br /> 过滤数组 = 冒泡排序(B)<br /> <br /> End Function<br /> Function 冒泡排序(ByVal A) As Variant<br /> '从小到大<br /> Dim i, j, n<br /> For i = 0 To UBound(A) - 1<br />     For j = 0 To UBound(A) - 1 - i<br />         If A(j) > A(j + 1) Then<br />             n = A(j + 1)<br />             A(j + 1) = A(j)<br />             A(j) = n<br />         End If<br />     Next j<br /> Next i<br /> 冒泡排序 = A<br /> End Function<br /> <br />

qwh923820

mikewolf2k 发表于 2018-8-23 16:01
如何判断是同一个单元格的？代码看起来太累，能说说么。粗略扫了一下，似乎是如果XY在前后行列的值之间，就 ...

是的，先如果某行某列全空，是被删除掉的。如果要精准判断，后续可以加入线条的坐标进行定位判断。
本程序流程

mikewolf2k

qwh923820 发表于 2018-8-23 16:40
是的，先如果某行某列全空，是被删除掉的。如果要精准判断，后续可以加入线条的坐标进行定位判断。
本程 ...

无论怎么判断，总能找出破绽，做不出通用的。只要能胜任要处理的表格就可以了。现在已经很不错了。

qwh923820

已经改成新建一个sheet，放入其中了

2. Option Explicit
   
3. Public Sub Cad表格转Excel()
   
4. Dim objEntArr() As Object, i As Long
   
5. Dim objSset As AcadSelectionSet
   
6. Dim y As AcadSelectionSet
   
7. 'Dim pt1(2) As Double, pt2(2) As Double
   
8. Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
   
9. Dim E()
   
10. 'pt1,pt2是表格的位置，左下，右上
    
11. 'pt1(0) = -1500
    
12. 'pt1(1) = -1500
    
13. 'pt1(2) = 0
    
14. 'pt2(0) = 43200
    
15. 'pt2(1) = 43200
    
16. 'pt2(2) = 0
    
17. Dim pt1, pt2
    
18. pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
19. pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
20. na = "QQQ"
    
21. k = 0
    
22. On Error Resume Next
    
23. If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    
24.     Set y = ThisDrawing.SelectionSets.Item(na)
    
25.     y.Delete
    
26. End If
    
27. Set y = ThisDrawing.SelectionSets.Add(na)
    
28.       Dim gpCode(0) As Integer
    
29.       Dim dataValue(0) As Variant
    
30.       gpCode(0) = 0
    
31.       dataValue(0) = "text,mtext"
    
32.       Dim groupCode As Variant, dataCode As Variant
    
33.       groupCode = gpCode
    
34.       dataCode = dataValue
    
35.   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
36.   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
37. y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    
38. 
    
39.     For i = 0 To y.Count - 1
    
40.         A(i + 1, 1) = i
    
41.         A(i + 1, 2) = y.Item(i).TextString
    
42.         p = y.Item(i).InsertionPoint
    
43.         k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙
    
44.         y.Item(i).GetBoundingBox m1, m2
    
45.         A(i + 1, 3) = p(0)
    
46.         A(i + 1, 4) = p(1)
    
47.         A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标
    
48.         A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半
    
49.         A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点
    
50.         A(i + 1, 5) = A(i + 1, 5) + A(i + 1, 6) / 2.5    '文字中心坐标往右偏
    
51.     Next i
    
52. y.Delete
    
53. ' Stop
    
54. 'k = 50     'k是过滤间隙
    
55. ky = k
    
56. kx = k * 1.2
    
57. B = 过滤数组(A, 4, ky)
    
58. C = 过滤数组(A, 7, kx)
    
59. 'Stop
    
60. ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
    
61. For i = 1 To UBound(A)
    
62.     If A(i, 2) = "" Then Exit For
    
63.     For n = 0 To UBound(B)
    
64.         '行的位置
    
65.         If Abs(B(n) - A(i, 4)) < ky Then
    
66.             Exit For
    
67.         End If
    
68.     Next n
    
69.     For m = 0 To UBound(C)
    
70.         '列的位置
    
71.         If Abs(C(m) - A(i, 7)) < kx Then
    
72.             Exit For
    
73.         End If
    
74.     Next m
    
75.     If D(UBound(B) + 1 - n, 1 + m) = "" Then
    
76.         D(UBound(B) + 1 - n, 1 + m) = i
    
77.     Else
    
78.         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)
    
79.     End If
    
80. Next i
    
81. E = 整合数组列(A, D, 1)
    
82. E = 替换文字内容(A, E)
    
83. Call EXCEL输出(E)
    
84. 'Dim exlh As Object
    
85. 'Set exlh = GetObject(, "excel.application")
    
86. 'With exlh
    
87. '    .workbooks(1).worksheets(1).Select
    
88. '    .cells.Select
    
89. '    .Selection.Clear
    
90. '    '.cells(1, 1).resize(990, 7) = A
    
91. '    '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D
    
92. '    .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E
    
93. '
    
94. 'End With
    
95. End Sub
    
96. 
    
97. Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant
    
98. 'A是数组，n是过滤的列，k是过滤的间隙
    
99. Dim B(), i, j, p, m
    
100. j = 0
     
101. ReDim B(0)
     
102. B(0) = A(1, n)
     
103. For i = 2 To UBound(A)
     
104.     m = 0
     
105.     If A(i, n) = "" Then Exit For
     
106.     For p = 0 To j
     
107.         If Abs(A(i, n) - B(p)) < k Then
     
108.             m = 1
     
109.             Exit For
     
110.         End If
     
111.     Next p
     
112.     If m = 0 Then
     
113.         j = j + 1
     
114.         ReDim Preserve B(j)
     
115.         B(j) = A(i, n)
     
116.     End If
     
117. Next i
     
118. 过滤数组 = 冒泡排序(B)
     
119. End Function
     
120. Function 冒泡排序(ByVal A) As Variant
     
121. '从小到大
     
122. Dim i, j, n
     
123. For i = 0 To UBound(A) - 1
     
124.     For j = 0 To UBound(A) - 1 - i
     
125.         If A(j) > A(j + 1) Then
     
126.             n = A(j + 1)
     
127.             A(j + 1) = A(j)
     
128.             A(j) = n
     
129.         End If
     
130.     Next j
     
131. Next i
     
132. 冒泡排序 = A
     
133. End Function
     
134. Function 整合数组列(ByVal A, ByVal D, ByVal n)
     
135. '以中心点和插入点间距为判断
     
136. '当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并
     
137. 'n列的插入点与中心点之间距离取该列最大值
     
138. Dim i, j, L, p, q, x1, x2, y, B, x3, x4
     
139. Dim C()
     
140. L = 0
     
141. If n >= UBound(D, 2) Then
     
142.     整合数组列 = D
     
143.     Exit Function
     
144. End If
     
145. 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
     
146. For i = 1 To UBound(D)
     
147.     If D(i, n) <> "" Then
     
148.         If InStr(D(i, n), "~~") > 0 Then
     
149.             B = Split(D(i, n), "~~")
     
150.             For j = 0 To UBound(B)
     
151.                 y = Abs(A(B(j), 5) - A(B(j), 3))
     
152.                 If L < y Then
     
153.                     L = y
     
154.                     x1 = A(B(j), 3): x2 = A(B(j), 5)
     
155.                 End If
     
156.             Next j
     
157.             Erase B
     
158.         Else
     
159.             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))
     
160.             If L < y Then
     
161.                 L = y
     
162.                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)
     
163.             End If
     
164.         End If
     
165.     End If
     
166. Next i
     
167. 'Stop
     
168. For i = 1 To UBound(D)
     
169. p = 0
     
170.     If D(i, n + 1) <> "" Then
     
171.     'Stop
     
172.         If InStr(D(i, n + 1), "~~") > 0 Then
     
173.             B = Split(D(i, n + 1), "~~")
     
174.             For j = 0 To UBound(B)
     
175.                 x3 = A(B(j), 3): x4 = A(B(j), 5)
     
176.                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then
     
177.                     p = 1
     
178.                     Exit For
     
179.                 End If
     
180.             Next j
     
181.             Erase B
     
182.         Else
     
183.             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
     
184.             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1
     
185.         End If
     
186.         If p = 1 Then
     
187.             If D(i, n) = "" Then
     
188.                 D(i, n) = D(i, n + 1)
     
189.             Else
     
190.                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
     
191.             End If
     
192.             D(i, n + 1) = ""
     
193.         End If
     
194.     End If
     
195. Next i
     
196. 'Call excelqingchu(n)
     
197. 'Call EXCEL输出(D)
     
198. C = 去除数组第N列空列(D, n + 1)
     
199. If UBound(C, 2) < UBound(D, 2) Then n = n - 1
     
200. 'If n = 10 Then Stop
     
201. 'Call EXCEL输出(C)
     
202. 'Stop
     
203. 整合数组列 = 整合数组列(A, C, n + 1)
     
204. End Function
     
205. Function 纵向排列同一单元格文字(ByVal A, ByVal t)
     
206. Dim B, i, j, k, C(), D(), E()
     
207. B = Split(t, "~~")
     
208. k = ""
     
209. ReDim C(UBound(B))
     
210. ReDim E(0 To UBound(B), 1 To 2)
     
211. For i = 0 To UBound(C)
     
212.     C(i) = A(B(i), 4)
     
213.     E(i, 1) = C(i)
     
214.     E(i, 2) = B(i)
     
215. Next i
     
216. Erase B
     
217. D = 冒泡排序(C)
     
218. For i = UBound(D) To 0 Step -1
     
219.     For j = 0 To UBound(D)
     
220.         If Abs(D(i) - E(j, 1)) < 0.001 Then
     
221.             If k = "" Then
     
222.                 k = E(j, 2)
     
223.             Else
     
224.                 k = k & "~~" & E(j, 2)
     
225.             End If
     
226.             E(j, 1) = -1235.778
     
227.         End If
     
228.     Next j
     
229. Next i
     
230. 纵向排列同一单元格文字 = k
     
231. End Function
     
232. Function 去除数组第N列空列(ByVal D, ByVal n)
     
233. Dim B(), i, j
     
234. For i = 1 To UBound(D)
     
235.     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function
     
236. Next i
     
237. ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
     
238. For i = 1 To UBound(D)
     
239.     For j = 1 To UBound(C, 2)
     
240.         If j < n Then
     
241.             C(i, j) = D(i, j)
     
242.         ElseIf j >= n Then
     
243.             C(i, j) = D(i, j + 1)
     
244.         End If
     
245.     Next j
     
246. Next i
     
247. 去除数组第N列空列 = C
     
248. End Function
     
249. Function 替换文字内容(ByVal A, ByVal D)
     
250. Dim B, i, j, k, n, m
     
251. For i = 1 To UBound(D)
     
252.     For j = 1 To UBound(D, 2)
     
253.         m = ""
     
254.         If D(i, j) <> "" Then
     
255.             If InStr(D(i, j), "~~") > 0 Then
     
256.                 B = Split(D(i, j), "~~")
     
257.                 For k = 0 To UBound(B)
     
258.                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
     
259.                 Next k
     
260.                 Erase B
     
261.             Else
     
262.                 m = A(D(i, j), 2)
     
263.             End If
     
264.             D(i, j) = m
     
265.         End If
     
266.     Next j
     
267. Next i
     
268. 替换文字内容 = D
     
269. End Function
     
270. Sub EXCEL输出(ByVal D)
     
271. Dim i, j, r
     
272. i = UBound(D)
     
273. j = UBound(D, 2)
     
274. Dim exlh As Object
     
275. Set exlh = GetObject(, "excel.application")
     
276. With exlh
     
277.     .workbooks(1).worksheets(1).Select
     
278.     .Sheets.Add
     
279.     'r = .cells(9999, 1).End(3).row + 2
     
280.     'If r < 3 Then r = 1
     
281.     r = 1
     
282.     .cells(r, 1).resize(i, j) = D
     
283.     .Range(.cells(1, 1), .cells(i, j)).Select
     
284.     .Selection.VerticalAlignment = 2
     
285.     .Selection.HorizontalAlignment = 3
     
286.     .Selection.Borders().LineStyle = 1
     
287. End With
     
288. 
     
289. End Sub
     
290. Sub excelqingchu(n)
     
291. Dim exlh As Object
     
292. Set exlh = GetObject(, "excel.application")
     
293. With exlh
     
294.     .workbooks(1).worksheets(1).Select
     
295.     .cells.Select
     
296.     .Selection.Clear
     
297. End With
     
298. End Sub

Option Explicit<br /> Public Sub Cad表格转Excel()<br /> Dim objEntArr() As Object, i As Long<br /> Dim objSset As AcadSelectionSet<br /> Dim y As AcadSelectionSet<br /> 'Dim pt1(2) As Double, pt2(2) As Double<br /> Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$<br /> Dim E()<br /> 'pt1,pt2是表格的位置，左下，右上<br /> 'pt1(0) = -1500<br /> 'pt1(1) = -1500<br /> 'pt1(2) = 0<br /> 'pt2(0) = 43200<br /> 'pt2(1) = 43200<br /> 'pt2(2) = 0<br /> Dim pt1, pt2<br /> pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br /> pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br /> na = "QQQ"<br /> k = 0<br /> On Error Resume Next<br /> If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then<br />     Set y = ThisDrawing.SelectionSets.Item(na)<br />     y.Delete<br /> End If<br /> Set y = ThisDrawing.SelectionSets.Add(na)<br />       Dim gpCode(0) As Integer<br />       Dim dataValue(0) As Variant<br />       gpCode(0) = 0<br />       dataValue(0) = "text,mtext"<br />       Dim groupCode As Variant, dataCode As Variant<br />       groupCode = gpCode<br />       dataCode = dataValue<br />   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br />   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br /> y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode<br /> <br />     For i = 0 To y.Count - 1<br />         A(i + 1, 1) = i<br />         A(i + 1, 2) = y.Item(i).TextString<br />         p = y.Item(i).InsertionPoint<br />         k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙<br />         y.Item(i).GetBoundingBox m1, m2<br />         A(i + 1, 3) = p(0)<br />         A(i + 1, 4) = p(1)<br />         A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标<br />         A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半<br />         A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点<br />         A(i + 1, 5) = A(i + 1, 5) + A(i + 1, 6) / 2.5    '文字中心坐标往右偏<br />     Next i<br /> y.Delete<br /> ' Stop<br /> 'k = 50     'k是过滤间隙<br /> ky = k<br /> kx = k * 1.2<br /> B = 过滤数组(A, 4, ky)<br /> C = 过滤数组(A, 7, kx)<br /> 'Stop<br /> ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)<br /> For i = 1 To UBound(A)<br />     If A(i, 2) = "" Then Exit For<br />     For n = 0 To UBound(B)<br />         '行的位置<br />         If Abs(B(n) - A(i, 4)) < ky Then<br />             Exit For<br />         End If<br />     Next n<br />     For m = 0 To UBound(C)<br />         '列的位置<br />         If Abs(C(m) - A(i, 7)) < kx Then<br />             Exit For<br />         End If<br />     Next m<br />     If D(UBound(B) + 1 - n, 1 + m) = "" Then<br />         D(UBound(B) + 1 - n, 1 + m) = i<br />     Else<br />         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)<br />     End If<br /> Next i<br /> E = 整合数组列(A, D, 1)<br /> E = 替换文字内容(A, E)<br /> Call EXCEL输出(E)<br /> 'Dim exlh As Object<br /> 'Set exlh = GetObject(, "excel.application")<br /> 'With exlh<br /> '    .workbooks(1).worksheets(1).Select<br /> '    .cells.Select<br /> '    .Selection.Clear<br /> '    '.cells(1, 1).resize(990, 7) = A<br /> '    '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D<br /> '    .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E<br /> '<br /> 'End With<br /> End Sub<br /> <br /> Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant<br /> 'A是数组，n是过滤的列，k是过滤的间隙<br /> Dim B(), i, j, p, m<br /> j = 0<br /> ReDim B(0)<br /> B(0) = A(1, n)<br /> For i = 2 To UBound(A)<br />     m = 0<br />     If A(i, n) = "" Then Exit For<br />     For p = 0 To j<br />         If Abs(A(i, n) - B(p)) < k Then<br />             m = 1<br />             Exit For<br />         End If<br />     Next p<br />     If m = 0 Then<br />         j = j + 1<br />         ReDim Preserve B(j)<br />         B(j) = A(i, n)<br />     End If<br /> Next i<br /> 过滤数组 = 冒泡排序(B)<br /> End Function<br /> Function 冒泡排序(ByVal A) As Variant<br /> '从小到大<br /> Dim i, j, n<br /> For i = 0 To UBound(A) - 1<br />     For j = 0 To UBound(A) - 1 - i<br />         If A(j) > A(j + 1) Then<br />             n = A(j + 1)<br />             A(j + 1) = A(j)<br />             A(j) = n<br />         End If<br />     Next j<br /> Next i<br /> 冒泡排序 = A<br /> End Function<br /> Function 整合数组列(ByVal A, ByVal D, ByVal n)<br /> '以中心点和插入点间距为判断<br /> '当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并<br /> 'n列的插入点与中心点之间距离取该列最大值<br /> Dim i, j, L, p, q, x1, x2, y, B, x3, x4<br /> Dim C()<br /> L = 0<br /> If n >= UBound(D, 2) Then<br />     整合数组列 = D<br />     Exit Function<br /> End If<br /> 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标<br /> For i = 1 To UBound(D)<br />     If D(i, n) <> "" Then<br />         If InStr(D(i, n), "~~") > 0 Then<br />             B = Split(D(i, n), "~~")<br />             For j = 0 To UBound(B)<br />                 y = Abs(A(B(j), 5) - A(B(j), 3))<br />                 If L < y Then<br />                     L = y<br />                     x1 = A(B(j), 3): x2 = A(B(j), 5)<br />                 End If<br />             Next j<br />             Erase B<br />         Else<br />             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))<br />             If L < y Then<br />                 L = y<br />                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)<br />             End If<br />         End If<br />     End If<br /> Next i<br /> 'Stop<br /> For i = 1 To UBound(D)<br /> p = 0<br />     If D(i, n + 1) <> "" Then<br />     'Stop<br />         If InStr(D(i, n + 1), "~~") > 0 Then<br />             B = Split(D(i, n + 1), "~~")<br />             For j = 0 To UBound(B)<br />                 x3 = A(B(j), 3): x4 = A(B(j), 5)<br />                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then<br />                     p = 1<br />                     Exit For<br />                 End If<br />             Next j<br />             Erase B<br />         Else<br />             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)<br />             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1<br />         End If<br />         If p = 1 Then<br />             If D(i, n) = "" Then<br />                 D(i, n) = D(i, n + 1)<br />             Else<br />                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))<br />             End If<br />             D(i, n + 1) = ""<br />         End If<br />     End If<br /> Next i<br /> 'Call excelqingchu(n)<br /> 'Call EXCEL输出(D)<br /> C = 去除数组第N列空列(D, n + 1)<br /> If UBound(C, 2) < UBound(D, 2) Then n = n - 1<br /> 'If n = 10 Then Stop<br /> 'Call EXCEL输出(C)<br /> 'Stop<br /> 整合数组列 = 整合数组列(A, C, n + 1)<br /> End Function<br /> Function 纵向排列同一单元格文字(ByVal A, ByVal t)<br /> Dim B, i, j, k, C(), D(), E()<br /> B = Split(t, "~~")<br /> k = ""<br /> ReDim C(UBound(B))<br /> ReDim E(0 To UBound(B), 1 To 2)<br /> For i = 0 To UBound(C)<br />     C(i) = A(B(i), 4)<br />     E(i, 1) = C(i)<br />     E(i, 2) = B(i)<br /> Next i<br /> Erase B<br /> D = 冒泡排序(C)<br /> For i = UBound(D) To 0 Step -1<br />     For j = 0 To UBound(D)<br />         If Abs(D(i) - E(j, 1)) < 0.001 Then<br />             If k = "" Then<br />                 k = E(j, 2)<br />             Else<br />                 k = k & "~~" & E(j, 2)<br />             End If<br />             E(j, 1) = -1235.778<br />         End If<br />     Next j<br /> Next i<br /> 纵向排列同一单元格文字 = k<br /> End Function<br /> Function 去除数组第N列空列(ByVal D, ByVal n)<br /> Dim B(), i, j<br /> For i = 1 To UBound(D)<br />     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function<br /> Next i<br /> ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)<br /> For i = 1 To UBound(D)<br />     For j = 1 To UBound(C, 2)<br />         If j < n Then<br />             C(i, j) = D(i, j)<br />         ElseIf j >= n Then<br />             C(i, j) = D(i, j + 1)<br />         End If<br />     Next j<br /> Next i<br /> 去除数组第N列空列 = C<br /> End Function<br /> Function 替换文字内容(ByVal A, ByVal D)<br /> Dim B, i, j, k, n, m<br /> For i = 1 To UBound(D)<br />     For j = 1 To UBound(D, 2)<br />         m = ""<br />         If D(i, j) <> "" Then<br />             If InStr(D(i, j), "~~") > 0 Then<br />                 B = Split(D(i, j), "~~")<br />                 For k = 0 To UBound(B)<br />                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)<br />                 Next k<br />                 Erase B<br />             Else<br />                 m = A(D(i, j), 2)<br />             End If<br />             D(i, j) = m<br />         End If<br />     Next j<br /> Next i<br /> 替换文字内容 = D<br /> End Function<br /> Sub EXCEL输出(ByVal D)<br /> Dim i, j, r<br /> i = UBound(D)<br /> j = UBound(D, 2)<br /> Dim exlh As Object<br /> Set exlh = GetObject(, "excel.application")<br /> With exlh<br />     .workbooks(1).worksheets(1).Select<br />     .Sheets.Add<br />     'r = .cells(9999, 1).End(3).row + 2<br />     'If r < 3 Then r = 1<br />     r = 1<br />     .cells(r, 1).resize(i, j) = D<br />     .Range(.cells(1, 1), .cells(i, j)).Select<br />     .Selection.VerticalAlignment = 2<br />     .Selection.HorizontalAlignment = 3<br />     .Selection.Borders().LineStyle = 1<br /> End With<br /> <br /> End Sub<br /> Sub excelqingchu(n)<br /> Dim exlh As Object<br /> Set exlh = GetObject(, "excel.application")<br /> With exlh<br />     .workbooks(1).worksheets(1).Select<br />     .cells.Select<br />     .Selection.Clear<br /> End With<br /> End Sub

qwh923820

zzyong00 发表于 2018-8-23 12:38
我十多年前就有类似的程序，还设置了容差对话框，但发现在实际使用时，问题太多了，才知道，当时的出发点就 ...

又修修改改，那个上标次方实在搞不定，其他帮忙鉴定下，后面附上源码

2. Option Explicit
   
3. 
   
4. Public Sub Cad表格转Excel()
   
5. Dim objEntArr() As Object, i As Long
   
6. Dim objSset As AcadSelectionSet
   
7. Dim y As AcadSelectionSet
   
8. Dim pt1(2) As Double, pt2(2) As Double
   
9. Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
   
10. Dim E()
    
11. 'pt1,pt2是表格的位置，左下，右上
    
12. pt1(0) = -1500
    
13. pt1(1) = -1500
    
14. pt1(2) = 0
    
15. pt2(0) = 43200
    
16. pt2(1) = 43200
    
17. pt2(2) = 0
    
18. na = "QQQ"
    
19. k = 0
    
20. On Error Resume Next
    
21. If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    
22.     Set y = ThisDrawing.SelectionSets.Item(na)
    
23.     y.Delete
    
24. End If
    
25. Set y = ThisDrawing.SelectionSets.Add(na)
    
26.       Dim gpCode(0) As Integer
    
27.       Dim dataValue(0) As Variant
    
28.       gpCode(0) = 0
    
29.       dataValue(0) = "text,mtext"
    
30.       Dim groupCode As Variant, dataCode As Variant
    
31.       groupCode = gpCode
    
32.       dataCode = dataValue
    
33.   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
34.   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    
35. y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    
36. 
    
37.     For i = 0 To y.Count - 1
    
38.         A(i + 1, 1) = i
    
39.         A(i + 1, 2) = y.Item(i).TextString
    
40.         p = y.Item(i).InsertionPoint
    
41.         k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙
    
42.         y.Item(i).GetBoundingBox m1, m2
    
43.         A(i + 1, 3) = p(0)
    
44.         A(i + 1, 4) = p(1)
    
45.         A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标
    
46.         A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半
    
47.         A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点
    
48.     Next i
    
49. y.Delete
    
50. ' Stop
    
51. 'k = 50     'k是过滤间隙
    
52. ky = k
    
53. kx = k * 1.2
    
54. B = 过滤数组(A, 4, ky)
    
55. C = 过滤数组(A, 7, kx)
    
56. ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
    
57. For i = 1 To UBound(A)
    
58.     If A(i, 2) = "" Then Exit For
    
59.     For n = 0 To UBound(B)
    
60.         '行的位置
    
61.         If Abs(B(n) - A(i, 4)) < ky Then
    
62.             Exit For
    
63.         End If
    
64.     Next n
    
65.     For m = 0 To UBound(B)
    
66.         '列的位置
    
67.         If Abs(C(m) - A(i, 7)) < kx Then
    
68.             Exit For
    
69.         End If
    
70.     Next m
    
71.     If D(UBound(B) + 1 - n, 1 + m) = "" Then
    
72.         D(UBound(B) + 1 - n, 1 + m) = i
    
73.     Else
    
74.         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)
    
75.     End If
    
76. Next i
    
77. E = 整合数组列(A, D, 1)
    
78. E = 替换文字内容(A, E)
    
79. Dim exlh As Object
    
80. Set exlh = GetObject(, "excel.application")
    
81. With exlh
    
82.     .workbooks(1).worksheets(1).Select
    
83.     .cells.Select
    
84.     .Selection.Clear
    
85.     '.cells(1, 1).resize(990, 7) = A
    
86.     '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D
    
87.     .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E
    
88.    
    
89. End With
    
90. End Sub
    
91. 
    
92. Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant
    
93. 'A是数组，n是过滤的列，k是过滤的间隙
    
94. Dim B(), i, j, p, m
    
95. j = 0
    
96. ReDim B(0)
    
97. B(0) = A(1, n)
    
98. For i = 2 To UBound(A)
    
99.     m = 0
    
100.     If A(i, n) = "" Then Exit For
     
101.     For p = 0 To j
     
102.         If Abs(A(i, n) - B(p)) < k Then
     
103.             m = 1
     
104.             Exit For
     
105.         End If
     
106.     Next p
     
107.     If m = 0 Then
     
108.         j = j + 1
     
109.         ReDim Preserve B(j)
     
110.         B(j) = A(i, n)
     
111.     End If
     
112. Next i
     
113. 过滤数组 = 冒泡排序(B)
     
114. End Function
     
115. Function 冒泡排序(ByVal A) As Variant
     
116. '从小到大
     
117. Dim i, j, n
     
118. For i = 0 To UBound(A) - 1
     
119.     For j = 0 To UBound(A) - 1 - i
     
120.         If A(j) > A(j + 1) Then
     
121.             n = A(j + 1)
     
122.             A(j + 1) = A(j)
     
123.             A(j) = n
     
124.         End If
     
125.     Next j
     
126. Next i
     
127. 冒泡排序 = A
     
128. End Function
     
129. Function 整合数组列(ByVal A, ByVal D, ByVal n)
     
130. '以中心点和插入点间距为判断
     
131. '当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并
     
132. 'n列的插入点与中心点之间距离取该列最大值
     
133. Dim i, j, L, p, q, x1, x2, y, B, x3, x4
     
134. Dim C()
     
135. L = 0
     
136. If n >= UBound(D, 2) Then
     
137.     整合数组列 = D
     
138.     Exit Function
     
139. End If
     
140. 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
     
141. For i = 1 To UBound(D)
     
142.     If D(i, n) <> "" Then
     
143.         If InStr(D(i, n), "~~") > 0 Then
     
144.             B = Split(D(i, n), "~~")
     
145.             For j = 0 To UBound(B)
     
146.                 y = Abs(A(B(j), 5) - A(B(j), 3))
     
147.                 If L > y Then
     
148.                     L = y
     
149.                     x1 = A(B(j), 3): x2 = A(B(j), 5)
     
150.                 End If
     
151.             Next j
     
152.             Erase B
     
153.         Else
     
154.             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))
     
155.             If L < y Then
     
156.                 L = y
     
157.                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)
     
158.             End If
     
159.         End If
     
160.     End If
     
161. Next i
     
162. 'Stop
     
163. For i = 1 To UBound(D)
     
164. p = 0
     
165.     If D(i, n + 1) <> "" Then
     
166.         If InStr(D(i, n + 1), "~~") > 0 Then
     
167.             B = Split(D(i, n + 1), "~~")
     
168.             For j = 0 To UBound(B)
     
169.                 x3 = A(B(j), 3): x4 = A(B(j), 5)
     
170.                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then
     
171.                     p = 1
     
172.                     Exit For
     
173.                 End If
     
174.             Next j
     
175.             Erase B
     
176.         Else
     
177.             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
     
178.             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1
     
179.         End If
     
180.         If p = 1 Then
     
181.             If D(i, n) = "" Then
     
182.                 D(i, n) = D(i, n + 1)
     
183.             Else
     
184.                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
     
185.             End If
     
186.             D(i, n + 1) = ""
     
187.         End If
     
188.     End If
     
189. Next i
     
190. C = 去除数组第N列空列(D, n + 1)
     
191. If UBound(C, 2) < UBound(D, 2) Then n = n - 1
     
192. 整合数组列 = 整合数组列(A, C, n + 1)
     
193. End Function
     
194. Function 纵向排列同一单元格文字(ByVal A, ByVal t)
     
195. Dim B, i, j, k, C(), D(), E()
     
196. B = Split(t, "~~")
     
197. k = ""
     
198. ReDim C(UBound(B))
     
199. ReDim E(0 To UBound(B), 1 To 2)
     
200. For i = 0 To UBound(C)
     
201.     C(i) = A(B(i), 4)
     
202.     E(i, 1) = C(i)
     
203.     E(i, 2) = B(i)
     
204. Next i
     
205. Erase B
     
206. D = 冒泡排序(C)
     
207. For i = UBound(D) To 0 Step -1
     
208.     For j = 0 To UBound(D)
     
209.         If Abs(D(i) - E(j, 1)) < 0.001 Then
     
210.             If k = "" Then
     
211.                 k = E(j, 2)
     
212.             Else
     
213.                 k = k & "~~" & E(j, 2)
     
214.             End If
     
215.             E(j, 1) = -1235.778
     
216.         End If
     
217.     Next j
     
218. Next i
     
219. 纵向排列同一单元格文字 = k
     
220. End Function
     
221. Function 去除数组第N列空列(ByVal D, ByVal n)
     
222. Dim B(), i, j
     
223. For i = 1 To UBound(D)
     
224.     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function
     
225. Next i
     
226. ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
     
227. For i = 1 To UBound(D)
     
228.     For j = 1 To UBound(C, 2)
     
229.         If j < n Then
     
230.             C(i, j) = D(i, j)
     
231.         ElseIf j >= n Then
     
232.             C(i, j) = D(i, j + 1)
     
233.         End If
     
234.     Next j
     
235. Next i
     
236. 去除数组第N列空列 = C
     
237. End Function
     
238. Function 替换文字内容(ByVal A, ByVal D)
     
239. Dim B, i, j, k, n, m
     
240. For i = 1 To UBound(D)
     
241.     For j = 1 To UBound(D, 2)
     
242.         m = ""
     
243.         If D(i, j) <> "" Then
     
244.             If InStr(D(i, j), "~~") > 0 Then
     
245.                 B = Split(D(i, j), "~~")
     
246.                 For k = 0 To UBound(B)
     
247.                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
     
248.                 Next k
     
249.                 Erase B
     
250.             Else
     
251.                 m = A(D(i, j), 2)
     
252.             End If
     
253.             D(i, j) = m
     
254.         End If
     
255.     Next j
     
256. Next i
     
257. 替换文字内容 = D
     
258. End Function
     

Option Explicit<br /> <br /> Public Sub Cad表格转Excel()<br /> Dim objEntArr() As Object, i As Long<br /> Dim objSset As AcadSelectionSet<br /> Dim y As AcadSelectionSet<br /> Dim pt1(2) As Double, pt2(2) As Double<br /> Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$<br /> Dim E()<br /> 'pt1,pt2是表格的位置，左下，右上<br /> pt1(0) = -1500<br /> pt1(1) = -1500<br /> pt1(2) = 0<br /> pt2(0) = 43200<br /> pt2(1) = 43200<br /> pt2(2) = 0<br /> na = "QQQ"<br /> k = 0<br /> On Error Resume Next<br /> If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then<br />     Set y = ThisDrawing.SelectionSets.Item(na)<br />     y.Delete<br /> End If<br /> Set y = ThisDrawing.SelectionSets.Add(na)<br />       Dim gpCode(0) As Integer<br />       Dim dataValue(0) As Variant<br />       gpCode(0) = 0<br />       dataValue(0) = "text,mtext"<br />       Dim groupCode As Variant, dataCode As Variant<br />       groupCode = gpCode<br />       dataCode = dataValue<br />   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br />   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")<br /> y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode<br /> <br />     For i = 0 To y.Count - 1<br />         A(i + 1, 1) = i<br />         A(i + 1, 2) = y.Item(i).TextString<br />         p = y.Item(i).InsertionPoint<br />         k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙<br />         y.Item(i).GetBoundingBox m1, m2<br />         A(i + 1, 3) = p(0)<br />         A(i + 1, 4) = p(1)<br />         A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标<br />         A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半<br />         A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点<br />     Next i<br /> y.Delete<br /> ' Stop<br /> 'k = 50     'k是过滤间隙<br /> ky = k<br /> kx = k * 1.2<br /> B = 过滤数组(A, 4, ky)<br /> C = 过滤数组(A, 7, kx)<br /> ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)<br /> For i = 1 To UBound(A)<br />     If A(i, 2) = "" Then Exit For<br />     For n = 0 To UBound(B)<br />         '行的位置<br />         If Abs(B(n) - A(i, 4)) < ky Then<br />             Exit For<br />         End If<br />     Next n<br />     For m = 0 To UBound(B)<br />         '列的位置<br />         If Abs(C(m) - A(i, 7)) < kx Then<br />             Exit For<br />         End If<br />     Next m<br />     If D(UBound(B) + 1 - n, 1 + m) = "" Then<br />         D(UBound(B) + 1 - n, 1 + m) = i<br />     Else<br />         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)<br />     End If<br /> Next i<br /> E = 整合数组列(A, D, 1)<br /> E = 替换文字内容(A, E)<br /> Dim exlh As Object<br /> Set exlh = GetObject(, "excel.application")<br /> With exlh<br />     .workbooks(1).worksheets(1).Select<br />     .cells.Select<br />     .Selection.Clear<br />     '.cells(1, 1).resize(990, 7) = A<br />     '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D<br />     .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E<br />     <br /> End With<br /> End Sub<br /> <br /> Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant<br /> 'A是数组，n是过滤的列，k是过滤的间隙<br /> Dim B(), i, j, p, m<br /> j = 0<br /> ReDim B(0)<br /> B(0) = A(1, n)<br /> For i = 2 To UBound(A)<br />     m = 0<br />     If A(i, n) = "" Then Exit For<br />     For p = 0 To j<br />         If Abs(A(i, n) - B(p)) < k Then<br />             m = 1<br />             Exit For<br />         End If<br />     Next p<br />     If m = 0 Then<br />         j = j + 1<br />         ReDim Preserve B(j)<br />         B(j) = A(i, n)<br />     End If<br /> Next i<br /> 过滤数组 = 冒泡排序(B)<br /> End Function<br /> Function 冒泡排序(ByVal A) As Variant<br /> '从小到大<br /> Dim i, j, n<br /> For i = 0 To UBound(A) - 1<br />     For j = 0 To UBound(A) - 1 - i<br />         If A(j) > A(j + 1) Then<br />             n = A(j + 1)<br />             A(j + 1) = A(j)<br />             A(j) = n<br />         End If<br />     Next j<br /> Next i<br /> 冒泡排序 = A<br /> End Function<br /> Function 整合数组列(ByVal A, ByVal D, ByVal n)<br /> '以中心点和插入点间距为判断<br /> '当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并<br /> 'n列的插入点与中心点之间距离取该列最大值<br /> Dim i, j, L, p, q, x1, x2, y, B, x3, x4<br /> Dim C()<br /> L = 0<br /> If n >= UBound(D, 2) Then<br />     整合数组列 = D<br />     Exit Function<br /> End If<br /> 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标<br /> For i = 1 To UBound(D)<br />     If D(i, n) <> "" Then<br />         If InStr(D(i, n), "~~") > 0 Then<br />             B = Split(D(i, n), "~~")<br />             For j = 0 To UBound(B)<br />                 y = Abs(A(B(j), 5) - A(B(j), 3))<br />                 If L > y Then<br />                     L = y<br />                     x1 = A(B(j), 3): x2 = A(B(j), 5)<br />                 End If<br />             Next j<br />             Erase B<br />         Else<br />             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))<br />             If L < y Then<br />                 L = y<br />                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)<br />             End If<br />         End If<br />     End If<br /> Next i<br /> 'Stop<br /> For i = 1 To UBound(D)<br /> p = 0<br />     If D(i, n + 1) <> "" Then<br />         If InStr(D(i, n + 1), "~~") > 0 Then<br />             B = Split(D(i, n + 1), "~~")<br />             For j = 0 To UBound(B)<br />                 x3 = A(B(j), 3): x4 = A(B(j), 5)<br />                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then<br />                     p = 1<br />                     Exit For<br />                 End If<br />             Next j<br />             Erase B<br />         Else<br />             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)<br />             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1<br />         End If<br />         If p = 1 Then<br />             If D(i, n) = "" Then<br />                 D(i, n) = D(i, n + 1)<br />             Else<br />                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))<br />             End If<br />             D(i, n + 1) = ""<br />         End If<br />     End If<br /> Next i<br /> C = 去除数组第N列空列(D, n + 1)<br /> If UBound(C, 2) < UBound(D, 2) Then n = n - 1<br /> 整合数组列 = 整合数组列(A, C, n + 1)<br /> End Function<br /> Function 纵向排列同一单元格文字(ByVal A, ByVal t)<br /> Dim B, i, j, k, C(), D(), E()<br /> B = Split(t, "~~")<br /> k = ""<br /> ReDim C(UBound(B))<br /> ReDim E(0 To UBound(B), 1 To 2)<br /> For i = 0 To UBound(C)<br />     C(i) = A(B(i), 4)<br />     E(i, 1) = C(i)<br />     E(i, 2) = B(i)<br /> Next i<br /> Erase B<br /> D = 冒泡排序(C)<br /> For i = UBound(D) To 0 Step -1<br />     For j = 0 To UBound(D)<br />         If Abs(D(i) - E(j, 1)) < 0.001 Then<br />             If k = "" Then<br />                 k = E(j, 2)<br />             Else<br />                 k = k & "~~" & E(j, 2)<br />             End If<br />             E(j, 1) = -1235.778<br />         End If<br />     Next j<br /> Next i<br /> 纵向排列同一单元格文字 = k<br /> End Function<br /> Function 去除数组第N列空列(ByVal D, ByVal n)<br /> Dim B(), i, j<br /> For i = 1 To UBound(D)<br />     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function<br /> Next i<br /> ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)<br /> For i = 1 To UBound(D)<br />     For j = 1 To UBound(C, 2)<br />         If j < n Then<br />             C(i, j) = D(i, j)<br />         ElseIf j >= n Then<br />             C(i, j) = D(i, j + 1)<br />         End If<br />     Next j<br /> Next i<br /> 去除数组第N列空列 = C<br /> End Function<br /> Function 替换文字内容(ByVal A, ByVal D)<br /> Dim B, i, j, k, n, m<br /> For i = 1 To UBound(D)<br />     For j = 1 To UBound(D, 2)<br />         m = ""<br />         If D(i, j) <> "" Then<br />             If InStr(D(i, j), "~~") > 0 Then<br />                 B = Split(D(i, j), "~~")<br />                 For k = 0 To UBound(B)<br />                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)<br />                 Next k<br />                 Erase B<br />             Else<br />                 m = A(D(i, j), 2)<br />             End If<br />             D(i, j) = m<br />         End If<br />     Next j<br /> Next i<br /> 替换文字内容 = D<br /> End Function<br />

dong20030432

有没有测试一下，如果这个CAD表格中有空数据的时候，输出到EXCEL中的对应单元格是否也是空的？

zzyong00

靠判断单元格文字位置这种思路不太可行，实际应用会有很多问题，我以前也有过类似思路的东西，最后只能是放弃

mikewolf2k

我是根据对齐点的位置，X/Y小于误差值内的算一行/列，然后遍历文本，看属于第几行第几列，然后填到相应单元格。

qwh923820

dong20030432 发表于 2018-8-22 09:56
有没有测试一下，如果这个CAD表格中有空数据的时候，输出到EXCEL中的对应单元格是否也是空的？

刚刚测试，可以的。附上测试结果对比

qwh923820

mikewolf2k 发表于 2018-8-22 13:12
我是根据对齐点的位置，X/Y小于误差值内的算一行/列，然后遍历文本，看属于第几行第几列，然后填到相应单元 ...

我也是这样的思想写的程序，根据不同情况改变文字间距的误差，小于误差属于同一行，或同一列。

qwh923820

zzyong00 发表于 2018-8-22 10:52
靠判断单元格文字位置这种思路不太可行，实际应用会有很多问题，我以前也有过类似思路的东西，最后只能是放 ...

暂时没发现问题，是否可赐教，或出现问题的情况

zzyong00

去先来个简单的表格，你先试试

zzyong00

再来个稍差一点的，更差的，就不上了

mikewolf2k

qwh923820 发表于 2018-8-22 13:35
我也是这样的思想写的程序，根据不同情况改变文字间距的误差，小于误差属于同一行，或同一列。

这一点你的思路是一样的，不过建议这个误差值不要写死在程序中，改成用户在程序运行中输入。
另外不同的对齐方式，对齐点是不一样的，有的是插入点，有的是对齐点，建议测试好后修改。
还有输出的单元格先清空下，不然如果原来sheet已经有多的数据，导出的数据改写了其中小的区域，不方便看出究竟哪些是导出的。
不断发现缺陷不断改进。加油！