Excel 将各种工作簿和工作表中的值复制到其他工作簿中

我试图循环浏览各种工作簿中的工作表并复制值（从单个单元格开始）。我需要将复制的值粘贴到新工作簿中的工作表中，在第一行中一个接一个地粘贴

我用三本作业本工作。每个工作簿有两张纸

我在三本工作簿中循环浏览所有工作表

出现以下问题：仅将第二张图纸中的值复制到主文件中

Sub RunOnAllFilesInFolder()

    Dim folderName As String, eApp As Excel.Application, fileName As String
    Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
    Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
    Dim ID As String
    Dim counter As Integer
    Dim i As Integer

    counter = 2
    fDialog.Title = "Select a folder"
    fDialog.InitialFileName = currWb.Path

    If fDialog.Show = -1 Then
        folderName = fDialog.SelectedItems(1)
    End If

    Set eApp = New Excel.Application: eApp.Visible = False
    Set eApp2 = New Excel.Application: eApp.Visible = False
    Set wb2 = eApp2.Workbooks.Add

    fileName = Dir(folderName & "\*.xls")

    Do While fileName <> ""

        Application.StatusBar = "Processing " & folderName & "\" & fileName
        Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)

        For Each ws In wb.Worksheets
            ws.Range("A1").Copy
        Next ws

        wb2.Worksheets(1).Cells(counter, 1).PasteSpecial xlPasteValues

        wb.Close SaveChanges:=False
        Debug.Print "Processed" & folderName & "\" & fileName
        fileName = Dir()
        counter = counter + 1

    Loop

    wb2.SaveAs ("Results.xlsx")
    eApp.Quit
    Set eApp = Nothing
    eApp2.Quit
    Set eApp2 = Nothing

    Application.StatusBar = ""
    MsgBox "Completed executing Macro"

End Sub

子文件信息文件夹（）
Dim folderName为字符串，eApp为Excel.Application，文件名为字符串
将wb设置为工作簿、ws设置为工作表、currWs设置为工作表、currWb设置为工作簿
Dim fDialog As Object:设置fDialog=Application.FileDialog（msoFileDialogFolderPicker）
Set currWb=ActiveWorkbook:Set currWs=ActiveSheet
作为字符串的Dim ID
作为整数的Dim计数器
作为整数的Dim i
计数器=2
fDialog.Title=“选择一个文件夹”
fDialog.InitialFileName=currWb.Path
如果fDialog.Show=-1，则
folderName=fDialog.SelectedItems（1）
如果结束
设置eApp=New Excel。应用程序：eApp.Visible=False
设置eApp2=New Excel。应用程序：eApp.Visible=False
设置wb2=eApp2.Workbooks.Add
fileName=Dir（folderName&“\*.xls”）
文件名“”时执行此操作
Application.StatusBar=“Processing”&folderName&“\”文件名
设置wb=eApp.Workbooks.Open（folderName&“\”文件名）
对于wb.工作表中的每个ws
ws.Range（“A1”）.副本
下一个ws
wb2.工作表（1）.单元格（计数器，1）.粘贴特殊值
wb.Close SaveChanges:=False
Debug.Print“Processed”&folderName&“\”文件名
fileName=Dir（）
计数器=计数器+1
环
wb2.SaveAs（“Results.xlsx”）
退出
设置eApp=Nothing
eApp2.退出
设置eApp2=无
Application.StatusBar=“”
MsgBox“已完成执行宏”
端接头

看起来问题在于工作表循环。您正在从工作表复制内容，但将值粘贴到工作表循环之后。这就是为什么只从一张图纸中获取值。下面的代码应该适合您

Sub RunOnAllFilesInFolder()

        Dim folderName As String, eApp As Excel.Application, fileName As String
        Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
        Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
        Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
        Dim ID As String
        Dim counter As Integer
        Dim i As Integer

        counter = 2
        fDialog.Title = "Select a folder"
        fDialog.InitialFileName = currWb.Path

        If fDialog.Show = -1 Then
            folderName = fDialog.SelectedItems(1)
        End If

        Set eApp = New Excel.Application: eApp.Visible = False
        Set eApp2 = New Excel.Application: eApp.Visible = False
        Set wb2 = eApp2.Workbooks.Add

        fileName = Dir(folderName & "\*.xls")

        Do While fileName <> ""

            Application.StatusBar = "Processing " & folderName & "\" & fileName
            Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)

            For Each ws In wb.Worksheets
                ws.Range("A1").Copy
                wb2.Worksheets(1).Cells(counter, 1).PasteSpecial xlPasteValues
                counter = counter + 1
            Next ws

            wb.Close SaveChanges:=False
            Debug.Print "Processed" & folderName & "\" & fileName
            fileName = Dir()
        Loop

        wb2.SaveAs ("Results.xlsx")
        eApp.Quit
        Set eApp = Nothing
        eApp2.Quit
        Set eApp2 = Nothing
        Application.StatusBar = ""
        MsgBox "Completed executing Macro"
    End Sub

子文件信息文件夹（）
Dim folderName为字符串，eApp为Excel.Application，文件名为字符串
将wb设置为工作簿、ws设置为工作表、currWs设置为工作表、currWb设置为工作簿
Dim fDialog As Object:设置fDialog=Application.FileDialog（msoFileDialogFolderPicker）
Set currWb=ActiveWorkbook:Set currWs=ActiveSheet
作为字符串的Dim ID
作为整数的Dim计数器
作为整数的Dim i
计数器=2
fDialog.Title=“选择一个文件夹”
fDialog.InitialFileName=currWb.Path
如果fDialog.Show=-1，则
folderName=fDialog.SelectedItems（1）
如果结束
设置eApp=New Excel。应用程序：eApp.Visible=False
设置eApp2=New Excel。应用程序：eApp.Visible=False
设置wb2=eApp2.Workbooks.Add
fileName=Dir（folderName&“\*.xls”）
文件名“”时执行此操作
Application.StatusBar=“Processing”&folderName&“\”文件名
设置wb=eApp.Workbooks.Open（folderName&“\”文件名）
对于wb.工作表中的每个ws
ws.Range（“A1”）.副本
wb2.工作表（1）.单元格（计数器，1）.粘贴特殊值
计数器=计数器+1
下一个ws
wb.Close SaveChanges:=False
Debug.Print“Processed”&folderName&“\”文件名
fileName=Dir（）
环
wb2.SaveAs（“Results.xlsx”）
退出
设置eApp=Nothing
eApp2.退出
设置eApp2=无
Application.StatusBar=“”
MsgBox“已完成执行宏”
端接头