想把C盘DATA里的文件合并到一个表里，该怎么操作？

蔚蓝0827

方式一：这是我从B站抄的代码，但运行后一点反应也没有
Sub ddd()
Dim FN As String
Dim Path As String
Dim i, r As Integer
Dim wkb As Workbook
Dim sht As Worksheet
Application.ScreenUpdating = False
Path = ThisWorkbook.Path & " \"
Set sht = Sheets("sheet1")
FN = Dir(Path & "*人力.xls*")
Do Until FN = ""
i = i + 1
Set wkb = Workbooks.Open(Path & FN)
[a1].CurrentRegion.Copy
r = sht.Range("a10000").End(xlUp).Row + 1
sht.Cells(r, 1).PasteSpecial
Application.CutCopyMode = False
wkb.Close False
FN = Dir
Loop
Application.ScreenUpdating = True
End Sub

方式二：我从百度复制的代码，但这句Wb.Sheets(G).UsedRange.Copy.Cells(.Range("B65536").End(xlUp).Row + 1, 1)运行不通过

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath,MyName, AWbName

Dim Wb AsWorkbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating= False

MyPath =ActiveWorkbook.Path

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

WithWorkbooks(1).ActiveSheet

.Cells(.Range("B65536").End(xlUp).Row+ 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 ToSheets.Count

Wb.Sheets(G).UsedRange.Copy.Cells(.Range("B65536").End(xlUp).Row + 1, 1)

Next

WbN = WbN &Chr(13) & Wb.Name

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("B1").Select

Application.ScreenUpdating= True

MsgBox "共合并了"& Num & "个工作薄下的全部工作表。如下：" &Chr(13) & WbN, vbInformation, "提示"

End Sub

求高人指点，究竟我该怎么办才能把这段代码跑通？或者有现成的简单代码发给我也行

蔚蓝0827

补充一句，是把内容全部合并到sheet1里

3190496160

看看这个工具是否能满足你的需求吧
https://club.excelhome.net/thread-1639995-1-1.html

opiona

https://club.excelhome.net/thread-1409141-1-1.html

ZHLK

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath,MyName, AWbName
Dim Wb AsWorkbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating= False
MyPath =ActiveWorkbook.Path
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
   For G = 1 To wb.Sheets.Count
      Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN &Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating= True
MsgBox "共合并了"& Num & "个工作薄下的全部工作表。如下：" &Chr(13) & WbN, vbInformation, "提示"
End Sub

梁锦鲤

要把代码中文件夹路径改成自己的，不懂的话还是建议使用PQ

fzxba

猜供参考无法测试.rar (16.29 KB, 下载次数: 1)

2023-3-26 13:33 上传

点击文件名下载附件