level 1
贴吧用户_0EXeR5G
楼主
Sub combin()
Dim d As Object
Dim newst As Worksheet
Dim sh As Worksheet
Dim m
Dim r, r2
Dim i
Set d = CreateObject("scripting.dictionary")
Set newst = Sheets.Add
newst.Name = "合并"
m = 2
For Each sh In Sheets
If sh.Name <> "合并" Then
For i = 1 To sh.UsedRange.Columns.Count
If Not d.exists(sh.Cells(1, i).Value) Then
d(sh.Cells(1, i).Value) = m
m = m + 1
End If
Next i
End If
Next sh
newst.Range("A1") = "工作表"
newst.Range(Cells(1, 2), Cells(1, d.Count + 1)) = d.keys
For Each sh In Sheets
If sh.Name <> "合并" Then
r = newst.UsedRange.Rows.Count + 1
For i = 1 To sh.UsedRange.Columns.Count
sh.UsedRange.Columns(i).Offset(1).Copy newst.Cells(r, d(sh.Cells(1, i).Value))
Next i
r2 = newst.UsedRange.Rows.Count
newst.Range("A" & r & ":A" & r2) = sh.Name
End If
Next sh
Set d = Nothing
End Sub
在.XLS 文件中可以 正常运行
复制到.XLSM文件中 运行错误1004 应用程序定义或对象定义错误
怎么解决
2023年11月15日 11点11分
1
Dim d As Object
Dim newst As Worksheet
Dim sh As Worksheet
Dim m
Dim r, r2
Dim i
Set d = CreateObject("scripting.dictionary")
Set newst = Sheets.Add
newst.Name = "合并"
m = 2
For Each sh In Sheets
If sh.Name <> "合并" Then
For i = 1 To sh.UsedRange.Columns.Count
If Not d.exists(sh.Cells(1, i).Value) Then
d(sh.Cells(1, i).Value) = m
m = m + 1
End If
Next i
End If
Next sh
newst.Range("A1") = "工作表"
newst.Range(Cells(1, 2), Cells(1, d.Count + 1)) = d.keys
For Each sh In Sheets
If sh.Name <> "合并" Then
r = newst.UsedRange.Rows.Count + 1
For i = 1 To sh.UsedRange.Columns.Count
sh.UsedRange.Columns(i).Offset(1).Copy newst.Cells(r, d(sh.Cells(1, i).Value))
Next i
r2 = newst.UsedRange.Rows.Count
newst.Range("A" & r & ":A" & r2) = sh.Name
End If
Next sh
Set d = Nothing
End Sub
在.XLS 文件中可以 正常运行
复制到.XLSM文件中 运行错误1004 应用程序定义或对象定义错误
怎么解决