VBA to copy data from multiple workbooks into master sheet

[excel_vba_1]

Hello Everyone!

I have to copy data from 10+ workbooks and paste it into a master workbook.
All the workbooks are located in a folder on my desktop: C:\Users\xbv\Desktop\group1

All the workbooks contain a sheet named 'appendix B', I have to open each workbook, go to sheet 'appendix B’, select columns range C to F starting from row 6 to row ‘x'(the last row can vary in each workbook), cntrl+v (copy), and paste the data range into master worksheet. In the master worksheet, I paste the data in Columns A to D and continue pasting/appending the data as I copy data from more workbooks. Eventually, the master workbook has the data in columns A to D from every workbook in one sheet.

The columns range C to F and starting from row 6 always remains constant in all the sheets (appendix B ) of every workbook. Each workbook contains 7 sheets, but I am only interested in sheet ‘appendix B’

I have to repeat the same steps for 10-30 workbooks and continue pasting/appending the data into master sheet. So, I was wondering if someone could please help me to create a VBA code for this? I'm really new to VBA and would really appreciate your help!

Please let me know if you require any clarification.

Many thanks! =)

 

[mumps]

This macro assumes that the Returns_All sheet is blank.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, wsDest As Worksheet, wkbSource As Workbook, colArr As Variant, fnd As Range, i As Long, lCol As Long
    Set wsDest = ThisWorkbook.Sheets("Returns_All")
    colArr = Array("Transactiondate", "Invoicedate", "Invoicenumber", "Supplierinvoicenumber", "Vatcode", "Taxablebasiscurrency2", _
        "Valuevatcurrency2", "Totalvaluelinecurrency2", "sinessPartnerName", "Client_comment", "Client_comment2")
    Const strPath As String = "C:\Users\R401054\Desktop\Job\2800 X-Company\DE\combined\"
    ChDir strPath
    strExtension = Dir("*.xlsb")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("IVAT_Format")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = LBound(colArr) To UBound(colArr)
                Set fnd = .Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    lCol = wsDest.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                    .Cells(1, fnd.Column).Resize(LastRow - 1).Copy wsDest.Cells(1, lCol)
                End If
            Next i
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    With wsDest
        .Columns.AutoFit
        .Columns(1).Delete
    End With
    Application.ScreenUpdating = True
End Sub

 

[HeinrichPaul]

Thanks a lot. I tested it with some excel files in the folder and it copied the columns beside each other, not all the columns specified. Would it be possible to get pasted data underneath each other?

Does it only copy unhidden cells or also hidden ones? Some of the columns are standard to be hidden by the supplier of those files. Then I would unhide what's needed.

 

[mumps]

Try this version of the macro. Have a look at the array in the code. You will notice that it includes all the column headers you listed in Post #70. The macro will copy only those columns. You will have to add and/or delete the array items to suit your needs to the desired columns. It is best to unhide the desired columns.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, wsDest As Worksheet, wkbSource As Workbook, colArr As Variant, fnd As Range, i As Long
    Set wsDest = ThisWorkbook.Sheets("Returns_All")
    colArr = Array("Transactiondate", "Invoicedate", "Invoicenumber", "Supplierinvoicenumber", "Vatcode", "Taxablebasiscurrency2", _
        "Valuevatcurrency2", "Totalvaluelinecurrency2", "sinessPartnerName", "Client_comment", "Client_comment2")
    Const strPath As String = "C:\Users\R401054\Desktop\Job\2800 X-Company\DE\combined\"
    ChDir strPath
    strExtension = Dir("*.xlsb")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("IVAT_Format")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = LBound(colArr) To UBound(colArr)
                Set fnd = .Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    .Cells(1, fnd.Column).Resize(LastRow - 1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
                End If
            Next i
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    With wsDest
        .Columns.AutoFit
        .Columns(1).Delete
    End With
    Application.ScreenUpdating = True
End Sub

 

[HeinrichPaul]

Doesn't happen anything on that one. What did you change? Was it this only?
If Not fnd Is Nothing Then
lCol = wsDest.Cells(1, Columns.Count).End(xlToLeft).Column + 1
.Cells(1, fnd.Column).Resize(LastRow - 1).Copy wsDest.Cells(1, lCol)
End If
Yes, added some more column headers into the array, works like a treat except for being all side by side.

 

[HeinrichPaul]

Couldn't get it working to copy underneath, did it manually. Was still a great help, thanks a lot for your quick help.

KR
Matthias

 

[HeinrichPaul]

Hello mumps,
sorry, but I am back. Just recognised that it's not copying all the lines. Sometimes it's the last one, not sure if always, but from the one file there were 6 lines missing. Before three, before one, now on second attempt only one is missing from before 6. Any idea what that might cause? Empty cells?

Matthias

 

[mumps]

Without seeing your file, it's hard to diagnose what the problem may be. Could you use the XL2BB add-in (icon in the menu) to post a screen shot (not a picture) of one or two of the "IVAT_Format" sheets. Alternately, you could upload a copy of one or two of the source files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[HeinrichPaul]

Yes will see, don't think it'll work on company laptop, but the desktop or to get a file prepared.

Without seeing your file, it's hard to diagnose what the problem may be. Could you use the XL2BB add-in (icon in the menu) to post a screen shot (not a picture) of one or two of the "IVAT_Format" sheets. Alternately, you could upload a copy of one or two of the source files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[Haoss]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    wkbDest.Sheets("Master").UsedRange.ClearContents
    Dim LastRow As Long
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).Copy
            wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hi Mumps i am back again
This code work well if i just put it under my personal desktop for personal use but it didn't work when i put all the related files into the share folder to be shared among my colleagues.
Any idea why?

 

[mumps]

I stay away from using shared folders so unfortunately, I don't have any experience in using them.