明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: qwh923820

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

  [复制链接]
发表于 2018-8-23 16:53 | 显示全部楼层
qwh923820 发表于 2018-8-23 16:40
是的,先如果某行某列全空,是被删除掉的。如果要精准判断,后续可以加入线条的坐标进行定位判断。
本程 ...

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

点评

Gu_xl版主有一个通过表格四角坐标判断的vlx插件,真的很不错  发表于 2018-8-26 14:06
回复 支持 1 反对 0

使用道具 举报

发表于 2018-8-26 23:54 | 显示全部楼层
好好学习楼主
发表于 2018-8-27 17:17 | 显示全部楼层
还有合并单元格需要考虑一下.
发表于 2018-9-7 20:57 | 显示全部楼层
你好怎么用啊,这个是vb吗
发表于 2018-9-12 11:26 | 显示全部楼层
qwh923820 发表于 2018-8-23 14:14
1.制定要转换的CAD表格位置,如果你想改成插件用,可以采用getpoint方法(就是注释掉的),如果你是写在 ...

如果采用getpoint方法,程序提示  编译错误:不能给数组赋值  是哪儿有问题吗,我在同一个文件里面其他的程序用getpoint则没有问题
 楼主| 发表于 2018-9-14 09:14 | 显示全部楼层
sxz4494 发表于 2018-9-12 11:26
如果采用getpoint方法,程序提示  编译错误:不能给数组赋值  是哪儿有问题吗,我在同一个文件里面其他的 ...

pt1,pt2原本定义的是数组,必须要注释掉,改成变体型vairant
如图修改:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2018-9-14 11:14 | 显示全部楼层
qwh923820 发表于 2018-9-14 09:14
pt1,pt2原本定义的是数组,必须要注释掉,改成变体型vairant
如图修改:

麻烦楼主看一下这个表,转出来有点错位。谢谢!

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2018-9-17 08:58 | 显示全部楼层
kosan 发表于 2018-9-14 11:14
麻烦楼主看一下这个表,转出来有点错位。谢谢!

原本程序有个BUG,现在已经改好了,新代码你再试试看吧!!




  1. Option Explicit

  2. Public Sub Cad表格转Excel()
  3. Dim objEntArr() As Object, i As Long
  4. Dim objSset As AcadSelectionSet
  5. Dim y As AcadSelectionSet
  6. 'Dim pt1(2) As Double, pt2(2) As Double
  7. Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
  8. Dim E()
  9. 'pt1,pt2是表格的位置,左下,右上
  10. 'pt1(0) = -1500
  11. 'pt1(1) = -1500
  12. 'pt1(2) = 0
  13. 'pt2(0) = 43200
  14. 'pt2(1) = 43200
  15. 'pt2(2) = 0
  16. Dim pt1, pt2
  17. pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  18. pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  19. na = "QQQ"
  20. k = 0
  21. On Error Resume Next
  22. If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
  23.     Set y = ThisDrawing.SelectionSets.Item(na)
  24.     y.Delete
  25. End If
  26. Set y = ThisDrawing.SelectionSets.Add(na)
  27.       Dim gpCode(0) As Integer
  28.       Dim dataValue(0) As Variant
  29.       gpCode(0) = 0
  30.       dataValue(0) = "text,mtext"
  31.       Dim groupCode As Variant, dataCode As Variant
  32.       groupCode = gpCode
  33.       dataCode = dataValue
  34.   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  35.   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  36. y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode

  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.         A(i + 1, 5) = A(i + 1, 5) + A(i + 1, 6) / 2.5    '文字中心坐标往右偏
  49.     Next i
  50. y.Delete
  51. ' Stop
  52. 'k = 50     'k是过滤间隙
  53. ky = k
  54. kx = k * 1.2
  55. B = 过滤数组(A, 4, ky)
  56. C = 过滤数组(A, 7, kx)
  57. 'Stop
  58. ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
  59. For i = 1 To UBound(A)
  60.     If A(i, 2) = "" Then Exit For
  61.     For n = 0 To UBound(B)
  62.         '行的位置
  63.         If Abs(B(n) - A(i, 4)) < ky Then
  64.             Exit For
  65.         End If
  66.     Next n
  67.     For m = 0 To UBound(C)
  68.         '列的位置
  69.         If Abs(C(m) - A(i, 7)) < kx Then
  70.             Exit For
  71.         End If
  72.     Next m
  73.     If D(UBound(B) + 1 - n, 1 + m) = "" Then
  74.         D(UBound(B) + 1 - n, 1 + m) = i
  75.     Else
  76.         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)
  77.     End If
  78. Next i
  79. E = 整合数组列(A, D, 1)
  80. E = 替换文字内容(A, E)
  81. Dim exlh As Object
  82. Set exlh = GetObject(, "excel.application")
  83. With exlh
  84.     .workbooks(1).worksheets(1).Select
  85.     .cells.Select
  86.     .Selection.Clear
  87.     '.cells(1, 1).resize(990, 7) = A
  88.     '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D
  89.     .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E
  90.    
  91. End With
  92. End Sub

  93. Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant
  94. 'A是数组,n是过滤的列,k是过滤的间隙
  95. Dim B(), i, j, p, m
  96. j = 0
  97. ReDim B(0)
  98. B(0) = A(1, n)
  99. For i = 2 To UBound(A)
  100.     m = 0
  101.     If A(i, n) = "" Then Exit For
  102.     For p = 0 To j
  103.         If Abs(A(i, n) - B(p)) < k Then
  104.             m = 1
  105.             Exit For
  106.         End If
  107.     Next p
  108.     If m = 0 Then
  109.         j = j + 1
  110.         ReDim Preserve B(j)
  111.         B(j) = A(i, n)
  112.     End If
  113. Next i
  114. 过滤数组 = 冒泡排序(B)
  115. End Function
  116. Function 冒泡排序(ByVal A) As Variant
  117. '从小到大
  118. Dim i, j, n
  119. For i = 0 To UBound(A) - 1
  120.     For j = 0 To UBound(A) - 1 - i
  121.         If A(j) > A(j + 1) Then
  122.             n = A(j + 1)
  123.             A(j + 1) = A(j)
  124.             A(j) = n
  125.         End If
  126.     Next j
  127. Next i
  128. 冒泡排序 = A
  129. End Function
  130. Function 整合数组列(ByVal A, ByVal D, ByVal n)
  131. '以中心点和插入点间距为判断
  132. '当相连两列n列与n+1列比较,n+1列文字插入点或中心点在n列的插入点与中心点之间时,合并
  133. 'n列的插入点与中心点之间距离取该列最大值
  134. Dim i, j, L, p, q, x1, x2, y, B, x3, x4
  135. Dim C()
  136. L = 0
  137. If n >= UBound(D, 2) Then
  138.     整合数组列 = D
  139.     Exit Function
  140. End If
  141. 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
  142. For i = 1 To UBound(D)
  143.     If D(i, n) <> "" Then
  144.         If InStr(D(i, n), "~~") > 0 Then
  145.             B = Split(D(i, n), "~~")
  146.             For j = 0 To UBound(B)
  147.                 y = Abs(A(B(j), 5) - A(B(j), 3))
  148.                 If L < y Then
  149.                     L = y
  150.                     x1 = A(B(j), 3): x2 = A(B(j), 5)
  151.                 End If
  152.             Next j
  153.             Erase B
  154.         Else
  155.             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))
  156.             If L < y Then
  157.                 L = y
  158.                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)
  159.             End If
  160.         End If
  161.     End If
  162. Next i
  163. 'Stop
  164. For i = 1 To UBound(D)
  165. p = 0
  166.     If D(i, n + 1) <> "" Then
  167.     'Stop
  168.         If InStr(D(i, n + 1), "~~") > 0 Then
  169.             B = Split(D(i, n + 1), "~~")
  170.             For j = 0 To UBound(B)
  171.                 x3 = A(B(j), 3): x4 = A(B(j), 5)
  172.                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then
  173.                     p = 1
  174.                     Exit For
  175.                 End If
  176.             Next j
  177.             Erase B
  178.         Else
  179.             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
  180.             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1
  181.         End If
  182.         If p = 1 Then
  183.             If D(i, n) = "" Then
  184.                 D(i, n) = D(i, n + 1)
  185.             Else
  186.                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
  187.             End If
  188.             D(i, n + 1) = ""
  189.         End If
  190.     End If
  191. Next i
  192. 'Call excelqingchu(n)
  193. 'Call EXCEL输出(D)
  194. C = 去除数组第N列空列(D, n + 1)
  195. If UBound(C, 2) < UBound(D, 2) Then n = n - 1
  196. 'If n = 10 Then Stop
  197. 'Call EXCEL输出(C)
  198. 'Stop
  199. 整合数组列 = 整合数组列(A, C, n + 1)
  200. End Function
  201. Function 纵向排列同一单元格文字(ByVal A, ByVal t)
  202. Dim B, i, j, k, C(), D(), E()
  203. B = Split(t, "~~")
  204. k = ""
  205. ReDim C(UBound(B))
  206. ReDim E(0 To UBound(B), 1 To 2)
  207. For i = 0 To UBound(C)
  208.     C(i) = A(B(i), 4)
  209.     E(i, 1) = C(i)
  210.     E(i, 2) = B(i)
  211. Next i
  212. Erase B
  213. D = 冒泡排序(C)
  214. For i = UBound(D) To 0 Step -1
  215.     For j = 0 To UBound(D)
  216.         If Abs(D(i) - E(j, 1)) < 0.001 Then
  217.             If k = "" Then
  218.                 k = E(j, 2)
  219.             Else
  220.                 k = k & "~~" & E(j, 2)
  221.             End If
  222.             E(j, 1) = -1235.778
  223.         End If
  224.     Next j
  225. Next i
  226. 纵向排列同一单元格文字 = k
  227. End Function
  228. Function 去除数组第N列空列(ByVal D, ByVal n)
  229. Dim B(), i, j
  230. For i = 1 To UBound(D)
  231.     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function
  232. Next i
  233. ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
  234. For i = 1 To UBound(D)
  235.     For j = 1 To UBound(C, 2)
  236.         If j < n Then
  237.             C(i, j) = D(i, j)
  238.         ElseIf j >= n Then
  239.             C(i, j) = D(i, j + 1)
  240.         End If
  241.     Next j
  242. Next i
  243. 去除数组第N列空列 = C
  244. End Function
  245. Function 替换文字内容(ByVal A, ByVal D)
  246. Dim B, i, j, k, n, m
  247. For i = 1 To UBound(D)
  248.     For j = 1 To UBound(D, 2)
  249.         m = ""
  250.         If D(i, j) <> "" Then
  251.             If InStr(D(i, j), "~~") > 0 Then
  252.                 B = Split(D(i, j), "~~")
  253.                 For k = 0 To UBound(B)
  254.                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
  255.                 Next k
  256.                 Erase B
  257.             Else
  258.                 m = A(D(i, j), 2)
  259.             End If
  260.             D(i, j) = m
  261.         End If
  262.     Next j
  263. Next i
  264. 替换文字内容 = D
  265. End Function
  266. Sub EXCEL输出(ByVal D)
  267. Dim i, j, r
  268. i = UBound(D)
  269. j = UBound(D, 2)
  270. Dim exlh As Object
  271. Set exlh = GetObject(, "excel.application")
  272. With exlh
  273.     .workbooks(1).worksheets(1).Select
  274.     r = .cells(9999, 1).End(3).row + 2
  275.     .cells(r, 1).resize(i, j) = D
  276.    
  277. End With

  278. End Sub
  279. Sub excelqingchu(n)
  280. Dim exlh As Object
  281. Set exlh = GetObject(, "excel.application")
  282. With exlh
  283.     .workbooks(1).worksheets(1).Select
  284.     .cells.Select
  285.     .Selection.Clear
  286. End With
  287. End Sub



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

刚刚扫了一眼getobject,建议新建sheet,现在很容易误删现在已有的sheet数据,而且无法undo。  发表于 2018-9-17 09:13
 楼主| 发表于 2018-9-17 09:39 | 显示全部楼层
已经改成新建一个sheet,放入其中了
  1. Option Explicit
  2. Public Sub Cad表格转Excel()
  3. Dim objEntArr() As Object, i As Long
  4. Dim objSset As AcadSelectionSet
  5. Dim y As AcadSelectionSet
  6. 'Dim pt1(2) As Double, pt2(2) As Double
  7. Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
  8. Dim E()
  9. 'pt1,pt2是表格的位置,左下,右上
  10. 'pt1(0) = -1500
  11. 'pt1(1) = -1500
  12. 'pt1(2) = 0
  13. 'pt2(0) = 43200
  14. 'pt2(1) = 43200
  15. 'pt2(2) = 0
  16. Dim pt1, pt2
  17. pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  18. pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  19. na = "QQQ"
  20. k = 0
  21. On Error Resume Next
  22. If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
  23.     Set y = ThisDrawing.SelectionSets.Item(na)
  24.     y.Delete
  25. End If
  26. Set y = ThisDrawing.SelectionSets.Add(na)
  27.       Dim gpCode(0) As Integer
  28.       Dim dataValue(0) As Variant
  29.       gpCode(0) = 0
  30.       dataValue(0) = "text,mtext"
  31.       Dim groupCode As Variant, dataCode As Variant
  32.       groupCode = gpCode
  33.       dataCode = dataValue
  34.   '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  35.   '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  36. y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode

  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.         A(i + 1, 5) = A(i + 1, 5) + A(i + 1, 6) / 2.5    '文字中心坐标往右偏
  49.     Next i
  50. y.Delete
  51. ' Stop
  52. 'k = 50     'k是过滤间隙
  53. ky = k
  54. kx = k * 1.2
  55. B = 过滤数组(A, 4, ky)
  56. C = 过滤数组(A, 7, kx)
  57. 'Stop
  58. ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
  59. For i = 1 To UBound(A)
  60.     If A(i, 2) = "" Then Exit For
  61.     For n = 0 To UBound(B)
  62.         '行的位置
  63.         If Abs(B(n) - A(i, 4)) < ky Then
  64.             Exit For
  65.         End If
  66.     Next n
  67.     For m = 0 To UBound(C)
  68.         '列的位置
  69.         If Abs(C(m) - A(i, 7)) < kx Then
  70.             Exit For
  71.         End If
  72.     Next m
  73.     If D(UBound(B) + 1 - n, 1 + m) = "" Then
  74.         D(UBound(B) + 1 - n, 1 + m) = i
  75.     Else
  76.         D(UBound(B) + 1 - n, 1 + m) = i & "~~" & D(UBound(B) + 1 - n, 1 + m)
  77.     End If
  78. Next i
  79. E = 整合数组列(A, D, 1)
  80. E = 替换文字内容(A, E)
  81. Call EXCEL输出(E)
  82. 'Dim exlh As Object
  83. 'Set exlh = GetObject(, "excel.application")
  84. 'With exlh
  85. '    .workbooks(1).worksheets(1).Select
  86. '    .cells.Select
  87. '    .Selection.Clear
  88. '    '.cells(1, 1).resize(990, 7) = A
  89. '    '.cells(1, 9).resize(UBound(B) + 1, UBound(C) + 1) = D
  90. '    .cells(1, 1).resize(UBound(E), UBound(E, 2)) = E
  91. '
  92. 'End With
  93. End Sub

  94. Function 过滤数组(ByVal A, ByVal n, ByVal k) As Variant
  95. 'A是数组,n是过滤的列,k是过滤的间隙
  96. Dim B(), i, j, p, m
  97. j = 0
  98. ReDim B(0)
  99. B(0) = A(1, n)
  100. For i = 2 To UBound(A)
  101.     m = 0
  102.     If A(i, n) = "" Then Exit For
  103.     For p = 0 To j
  104.         If Abs(A(i, n) - B(p)) < k Then
  105.             m = 1
  106.             Exit For
  107.         End If
  108.     Next p
  109.     If m = 0 Then
  110.         j = j + 1
  111.         ReDim Preserve B(j)
  112.         B(j) = A(i, n)
  113.     End If
  114. Next i
  115. 过滤数组 = 冒泡排序(B)
  116. End Function
  117. Function 冒泡排序(ByVal A) As Variant
  118. '从小到大
  119. Dim i, j, n
  120. For i = 0 To UBound(A) - 1
  121.     For j = 0 To UBound(A) - 1 - i
  122.         If A(j) > A(j + 1) Then
  123.             n = A(j + 1)
  124.             A(j + 1) = A(j)
  125.             A(j) = n
  126.         End If
  127.     Next j
  128. Next i
  129. 冒泡排序 = A
  130. End Function
  131. Function 整合数组列(ByVal A, ByVal D, ByVal n)
  132. '以中心点和插入点间距为判断
  133. '当相连两列n列与n+1列比较,n+1列文字插入点或中心点在n列的插入点与中心点之间时,合并
  134. 'n列的插入点与中心点之间距离取该列最大值
  135. Dim i, j, L, p, q, x1, x2, y, B, x3, x4
  136. Dim C()
  137. L = 0
  138. If n >= UBound(D, 2) Then
  139.     整合数组列 = D
  140.     Exit Function
  141. End If
  142. 'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
  143. For i = 1 To UBound(D)
  144.     If D(i, n) <> "" Then
  145.         If InStr(D(i, n), "~~") > 0 Then
  146.             B = Split(D(i, n), "~~")
  147.             For j = 0 To UBound(B)
  148.                 y = Abs(A(B(j), 5) - A(B(j), 3))
  149.                 If L < y Then
  150.                     L = y
  151.                     x1 = A(B(j), 3): x2 = A(B(j), 5)
  152.                 End If
  153.             Next j
  154.             Erase B
  155.         Else
  156.             y = Abs(A(D(i, n), 5) - A(D(i, n), 3))
  157.             If L < y Then
  158.                 L = y
  159.                 x1 = A(D(i, n), 3): x2 = A(D(i, n), 5)
  160.             End If
  161.         End If
  162.     End If
  163. Next i
  164. 'Stop
  165. For i = 1 To UBound(D)
  166. p = 0
  167.     If D(i, n + 1) <> "" Then
  168.     'Stop
  169.         If InStr(D(i, n + 1), "~~") > 0 Then
  170.             B = Split(D(i, n + 1), "~~")
  171.             For j = 0 To UBound(B)
  172.                 x3 = A(B(j), 3): x4 = A(B(j), 5)
  173.                 If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then
  174.                     p = 1
  175.                     Exit For
  176.                 End If
  177.             Next j
  178.             Erase B
  179.         Else
  180.             x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
  181.             If IIf(x3 > x4, x4, x3) < IIf(x2 > x1, x2, x1) Then p = 1
  182.         End If
  183.         If p = 1 Then
  184.             If D(i, n) = "" Then
  185.                 D(i, n) = D(i, n + 1)
  186.             Else
  187.                 D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
  188.             End If
  189.             D(i, n + 1) = ""
  190.         End If
  191.     End If
  192. Next i
  193. 'Call excelqingchu(n)
  194. 'Call EXCEL输出(D)
  195. C = 去除数组第N列空列(D, n + 1)
  196. If UBound(C, 2) < UBound(D, 2) Then n = n - 1
  197. 'If n = 10 Then Stop
  198. 'Call EXCEL输出(C)
  199. 'Stop
  200. 整合数组列 = 整合数组列(A, C, n + 1)
  201. End Function
  202. Function 纵向排列同一单元格文字(ByVal A, ByVal t)
  203. Dim B, i, j, k, C(), D(), E()
  204. B = Split(t, "~~")
  205. k = ""
  206. ReDim C(UBound(B))
  207. ReDim E(0 To UBound(B), 1 To 2)
  208. For i = 0 To UBound(C)
  209.     C(i) = A(B(i), 4)
  210.     E(i, 1) = C(i)
  211.     E(i, 2) = B(i)
  212. Next i
  213. Erase B
  214. D = 冒泡排序(C)
  215. For i = UBound(D) To 0 Step -1
  216.     For j = 0 To UBound(D)
  217.         If Abs(D(i) - E(j, 1)) < 0.001 Then
  218.             If k = "" Then
  219.                 k = E(j, 2)
  220.             Else
  221.                 k = k & "~~" & E(j, 2)
  222.             End If
  223.             E(j, 1) = -1235.778
  224.         End If
  225.     Next j
  226. Next i
  227. 纵向排列同一单元格文字 = k
  228. End Function
  229. Function 去除数组第N列空列(ByVal D, ByVal n)
  230. Dim B(), i, j
  231. For i = 1 To UBound(D)
  232.     If D(i, n) <> "" Then 去除数组第N列空列 = D: Exit Function
  233. Next i
  234. ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
  235. For i = 1 To UBound(D)
  236.     For j = 1 To UBound(C, 2)
  237.         If j < n Then
  238.             C(i, j) = D(i, j)
  239.         ElseIf j >= n Then
  240.             C(i, j) = D(i, j + 1)
  241.         End If
  242.     Next j
  243. Next i
  244. 去除数组第N列空列 = C
  245. End Function
  246. Function 替换文字内容(ByVal A, ByVal D)
  247. Dim B, i, j, k, n, m
  248. For i = 1 To UBound(D)
  249.     For j = 1 To UBound(D, 2)
  250.         m = ""
  251.         If D(i, j) <> "" Then
  252.             If InStr(D(i, j), "~~") > 0 Then
  253.                 B = Split(D(i, j), "~~")
  254.                 For k = 0 To UBound(B)
  255.                     If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
  256.                 Next k
  257.                 Erase B
  258.             Else
  259.                 m = A(D(i, j), 2)
  260.             End If
  261.             D(i, j) = m
  262.         End If
  263.     Next j
  264. Next i
  265. 替换文字内容 = D
  266. End Function
  267. Sub EXCEL输出(ByVal D)
  268. Dim i, j, r
  269. i = UBound(D)
  270. j = UBound(D, 2)
  271. Dim exlh As Object
  272. Set exlh = GetObject(, "excel.application")
  273. With exlh
  274.     .workbooks(1).worksheets(1).Select
  275.     .Sheets.Add
  276.     'r = .cells(9999, 1).End(3).row + 2
  277.     'If r < 3 Then r = 1
  278.     r = 1
  279.     .cells(r, 1).resize(i, j) = D
  280.     .Range(.cells(1, 1), .cells(i, j)).Select
  281.     .Selection.VerticalAlignment = 2
  282.     .Selection.HorizontalAlignment = 3
  283.     .Selection.Borders().LineStyle = 1
  284. End With

  285. End Sub
  286. Sub excelqingchu(n)
  287. Dim exlh As Object
  288. Set exlh = GetObject(, "excel.application")
  289. With exlh
  290.     .workbooks(1).worksheets(1).Select
  291.     .cells.Select
  292.     .Selection.Clear
  293. End With
  294. End Sub


回复 支持 1 反对 0

使用道具 举报

发表于 2018-9-17 09:57 | 显示全部楼层
本帖最后由 kosan 于 2018-9-17 09:58 编辑
qwh923820 发表于 2018-9-17 09:39
已经改成新建一个sheet,放入其中了

提取的数据不完整?上面的那个CAD表格文件,多粘贴几遍,列数弄多一点。比如100列,但是EXCEL中输出的只有二三十列,而且每次列数不尽相同。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 21:02 , Processed in 0.214505 second(s), 18 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表