VBA从多个关闭的文件中提取数据 Private子命令按钮1\u单击（） Dim目录为字符串，文件名为字符串，工作表为工作表，总计为整数 Application.ScreenUpdating=False Application.DisplayAlerts=False directory=“c:\凭证” fileName=Dir（目录&“*.csv？？”） 文件名“”时执行此操作 工作簿.打开（目录和文件名） 对于工作簿中的每张工作表（文件名）。工作表 总计=工作簿（“凭证报告26MAR V1.0.xlsm”）。工作表。计数 工作簿（文件名）.工作表（工作表.名称）.复制_ 之后：=工作簿（“凭证报告26MAR V1.0.xlsm”）。工作表（总计） 下一页 工作簿（文件名）。关闭 fileName=Dir（） 环 Application.ScreenUpdating=True Application.DisplayAlerts=True 端接头

上面的代码获取了我需要的所有数据，但为每个工作簿创建了一个新的工作表，是否要将第一个工作簿中的数据放在第10行，然后将下一个工作簿中的数据添加到下一个可用行

试试这个。注意，您可能需要调整

Dest

工作表的值，我已经根据您的代码尽可能地对其进行了定义

Private Sub CommandButton1_Click()

Dim directory As String, fileName As String, sheet As Worksheet, total As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")

Do While fileName <> ""

Workbooks.Open (directory & fileName)

For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy _
after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets(total)
Next sheet

Workbooks(fileName).Close

fileName = Dir()

Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

Private子命令按钮1\u单击（）
Dim目录为字符串，文件名为字符串，工作表为工作表，总计为整数
将Dest设置为工作表
变暗，尽可能长
将源设置为工作簿
'根据需要进行调整-它应在工作结束时创建新的工作表
“凭证报告…”，并称之为“我的新工作表”
Set Dest=工作簿（“凭证报告26MAR V1.0.xlsm”）。Worksheets.add_
之后：=工作簿（“凭证报告26MAR V1.0.xlsm”）。工作表。计数_
名称：=“我的新工作表”
DestRow=10
Application.ScreenUpdating=False
Application.DisplayAlerts=False
directory=“c:\凭证”
fileName=Dir（目录&“*.csv？？”）
文件名“”时执行此操作
'将打开的工作簿分配给变量以便于使用
设置source=Workbooks.Open（目录和文件名）
对于源工作表中的每个工作表
'从工作表中复制UsedRange单元格
“抄袭有点奇怪，但这行得通
单元格（1,1）.调整大小（sheet.usedrange.rows.count，sheet.usedrange.columns.count）.复制
'粘贴不应用于范围，而是应用于工作表对象
'目标参数告诉它去哪里
目的地粘贴目的地：=范围（单元格（删除“A”）
'增加当前行指针，但增加使用的行数
destrow=destrow+sheet.usedrange.rows.count
下一页
工作簿（文件名）。关闭
fileName=Dir（）
环
Application.ScreenUpdating=True
Application.DisplayAlerts=True
端接头

所有代码都未经测试，因此您可能会有一些小的调整。我建议注释掉

屏幕更新

行，直到所有代码都正常工作

---

注意：我在中找到了

.copy

的引用，在中找到了

.paste

的引用。

我无法使Dest正常工作，因此我将其更改为：Set Dest=thishworkbook.Sheets.Add（之后：=thishworkbook.Sheets（thishworkbook.Sheets.Count））Dest.Name=“我的新工作表”这确实添加了一张新闻纸，但现在我遇到了复制部分错误1004的问题。似乎

。复制
和
。粘贴
的工作方式有点不同。请检查更新的代码
Private Sub CommandButton1_Click()

Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim Dest as Worksheet
Dim DestRow as long
Dim Source as Workbook

'adjust this as necessary - it should create a new sheet at the end of 
'"Voucher Report...", and call it "My New Sheet"
Set Dest = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.add _
           after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count _
           Name:="My New Sheet"
DestRow = 10
Application.ScreenUpdating = False
Application.DisplayAlerts = False

directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")

Do While fileName <> ""
  'assign the opened workbook to a var for easier use
  set source = Workbooks.Open (directory & fileName)
  For Each sheet In source.Worksheets
    'copy the UsedRange cells from the sheet
    '.copy is kind of weird, but this works
    sheet.cells(1,1).resize(sheet.usedrange.rows.count, sheet.usedrange.columns.count).copy
    'paste doesn't apply to a range, but to a worksheet object
    '   the destination param tells it where to go
    dest.paste destination:=range(cells(destrow,"A")
    'increment the current row pointer but the number of rows used
    destrow = destrow + sheet.usedrange.rows.count
  Next sheet
  Workbooks(fileName).Close
  fileName = Dir()
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub