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

Question

我正在尝试遍历各种工作簿中的工作表并复制值（从单个单元格开始）。我需要将复制的值粘贴到新工作簿中的工作表中，该工作表在第一行中的另一个下面。

我处理了三本工作簿。每个工作簿都有两页。

我循环浏览三个工作簿中的所有工作表。

发生以下问题：仅将第二张纸中的值复制到主文件中。

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

Answer 1

看起来问题出在您的工作表循环中。您正在从工作表中复制内容，但是将值粘贴到工作表循环之后。这就是为什么您仅从一张纸获得价值的原因。下面的代码将为您工作。

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