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

qwh923820 · 发表于 2018-8-22 09:34:12

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

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

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

qwh923820 · 发表于 2018-8-23 16:40:56

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

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

mikewolf2k · 发表于 2018-8-23 16:53:02

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

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

qwh923820 · 发表于 2018-9-17 09:39:33

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

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

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

qwh923820 · 发表于 2018-8-23 13:58:42

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

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

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

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

dong20030432 · 发表于 2018-8-22 09:56:42

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

zzyong00 · 发表于 2018-8-22 10:52:39

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

mikewolf2k · 发表于 2018-8-22 13:12:04

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

qwh923820 · 发表于 2018-8-22 13:33:50

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

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

qwh923820 · 发表于 2018-8-22 13:35:30

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

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

qwh923820 · 发表于 2018-8-22 13:36:39

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

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

zzyong00 · 发表于 2018-8-22 13:39:53

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

zzyong00 · 发表于 2018-8-22 13:41:56

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

mikewolf2k · 发表于 2018-8-22 14:46:18

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

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

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

点评

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源