Copy the same cells from every sheet of multiple excel files

Question

I have multiple excel files that contain different amount of sheets. I need to copy specific cells from every sheet to a new workbook, to the following columns - vault (from T3), date (from G6), pickup (from V10), refund (V13), load (V11), unload (V12), opening (V9), closing (V14) and also indicate the name of the sourcefile in the last column.

I am just a hopeless copy-paste warrior, so I am not really into VBA, but I found the code below which works OK, but only for Sheet1 in every file. (Probably it would fail if I changed sheet number to 6 for example because not every file contains 6 sheets.) Maybe there is a way to modify this one to copy cells from all sheets. Or should I start a totally different one?

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

Teamothy Teamothy · Accepted Answer · 2019-10-29T09:58:32

Try this: (added for each loop for every worksheets in opened workbook)

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

Copy the same cells from every sheet of multiple excel files

1 Answers