從多個 excel 文件的每個工作表中復制相同的單元格

Question

我有多個包含不同數量紙張的 excel 文件。 我需要將每個工作表中的特定單元格復制到新工作簿中，復制到以下列 - 保險庫（來自 T3）、日期（來自 G6）、取貨（來自 V10）、退款（V13）、加載（V11）、卸載（V12 )、打開 (V9)、關閉 (V14) 並且還在最后一列中指明源文件的名稱。

我只是一個無望的復制粘貼戰士，所以我並不真正喜歡 VBA，但我發現下面的代碼可以正常工作，但僅適用於每個文件中的 Sheet1。 （例如，如果我將工作表編號更改為 6，可能會失敗，因為並非每個文件都包含 6 張工作表。）也許有一種方法可以修改這個以復制所有工作表中的單元格。 還是我應該開始一個完全不同的？

Sub copyfromsheet()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range

Set destsheet = ThisWorkbook.Worksheets(1)
Set RngDest = destsheet.Cells(Rows.Count, 2).End(xlUp) _
                       .Offset(2, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xls*")

'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
    If Fname <> ThisWorkbook.Name Then
        Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
        Set originsheet = wkbkorigin.Worksheets(1)

        With RngDest
            .Cells(1).Value = originsheet.Range("T3").Value 'vault
            .Cells(2).Value = originsheet.Range("G6").Value 'date
            .Cells(3).Value = originsheet.Range("V10").Value 'pickup
            .Cells(4).Value = originsheet.Range("V13").Value 'refund
            .Cells(5).Value = originsheet.Range("V11").Value 'load
            .Cells(6).Value = originsheet.Range("V12").Value 'unload
            .Cells(7).Value = originsheet.Range("V9").Value 'opening
            .Cells(8).Value = originsheet.Range("V14").Value 'closing
            .Cells(9).Value = wkbkorigin.Name 'wbk name H
        End With

        wkbkorigin.Close SaveChanges:=False   'close current file
        Set RngDest = RngDest.Offset(1, 0)
    End If

    Fname = Dir()     'get next file
Loop

End Sub

Answer 1

試試這個：（為打開的工作簿中的每個工作表的每個循環添加）

Option Explicit

Sub copyfromsheet()

    Dim wkbkorigin As Workbook, destsheet As Worksheet
    Dim originsheet As Worksheet, RngDest As Range
    Dim Fname$ 

    Set destsheet = ThisWorkbook.Worksheets(1)

    Fname = Dir(ThisWorkbook.Path & "/*.xls*")

    'loop through each file in folder (excluding this one)
    Do While Fname <> "" And Fname <> ThisWorkbook.Name

        If Fname <> ThisWorkbook.Name Then

            Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)

            For Each originsheet In wkbkorigin.Sheets

                Set RngDest = destsheet.Cells(Rows.Count, 2).End(xlUp) _
                       .Offset(2, 0).EntireRow

                With RngDest
                    .Cells(1).Value = originsheet.Range("T3").Value 'vault
                    .Cells(2).Value = originsheet.Range("G6").Value 'date
                    .Cells(3).Value = originsheet.Range("V10").Value 'pickup
                    .Cells(4).Value = originsheet.Range("V13").Value 'refund
                    .Cells(5).Value = originsheet.Range("V11").Value 'load
                    .Cells(6).Value = originsheet.Range("V12").Value 'unload
                    .Cells(7).Value = originsheet.Range("V9").Value 'opening
                    .Cells(8).Value = originsheet.Range("V14").Value 'closing
                    .Cells(9).Value = wkbkorigin.Name 'wbk name H
                End With

            Next

            wkbkorigin.Close SaveChanges:=False   'close current file

        End If

        Fname = Dir()     'get next file
    Loop

End Sub