excel VBA 编程

你是要添加一个工作簿还是一个工作表呀？
工作簿
Sub 锅炉清单()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String, Wb1 As Workbook
Dim G As Long
Dim Num As Long
Dim BOX As String
Set Wb1 = Workbooks.Add(xlWBATWorksheet) '添加一个只有一个表的工作簿
Wb1.Worksheets(1).Name = "统计表" '修改表名
Application.ScreenUpdating = False
MyPath = "E:\特设类\档案管理\数据库\锅炉清单"
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If Num = 1 Then
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy Wb1.Sheets(1).Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
Else
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy Wb1.Sheets(1).Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Wb1.Sheets(1).Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共统计了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
工作表
Sub 锅炉清单()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String, Wb1 As Worksheet
Dim G As Long
Dim Num As Long
Dim BOX As String
Set Wb1 = Worksheets.Add '添加一个工作表
Wb1.Name = "统计表" '修改表名
Application.ScreenUpdating = False
MyPath = "E:\特设类\档案管理\数据库\锅炉清单"
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If Num = 1 Then
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy Wb1.Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
Else
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy Wb1.Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Wb1.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共统计了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub追问

老师你好,添加工作簿那个程序
我运行了，新的工作薄建好，并写入统计内容，但是没能把名字更名，
最大的问题是：我要统计指定路径下的一个文件夹中的N个excel中的内容，这N个EXCEL表的第一行都是标题，只复制第一个excel表的标题（标题都一样的），之后的excel表从第二行开始复制出来，但是这个程序运行出来的就乱了，有些就统计不了了，像是被之后复制的覆盖了
老师您辛苦了！！！

追答

你的第一个工作表有几列呢？
你看是不是这样
Sub 锅炉清单()
Dim MyPath, MyName, AWbName, arr, brr
Dim Wb As Workbook, WbN As String, Wb1 As Workbook
Dim G As Long
Dim Num As Long
Dim BOX As String
Set Wb1 = Workbooks.Add(xlWBATWorksheet) '添加一个只有一个表的工作簿
Wb1.Worksheets(1).Name = "统计表" '修改表名
Application.ScreenUpdating = False
MyPath = "E:\特设类\档案管理\数据库\锅炉清单"
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName ""
If MyName AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
If Num = 1 Then
Wb.Sheets(G).UsedRange.Copy Wb1.Sheets(1).Cells(65536, 1).End(xlUp).Offset(1)
Else
arr = Wb.Sheets(1).UsedRange
ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
For G = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
brr(G - 1, j) = arr(G, j)
Next j
Next G
Wb1.Sheets(1).Cells(65536, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = brr
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End If
MyName = Dir
Loop
Wb1.Sheets(1).Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共统计了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

追问

我已经调试好了
老师辛苦了，谢谢！

温馨提示：答案为网友推荐，仅供参考

当前网址：https://verywind.cn/ee/ye7fy23yr.html