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! =)

 

[Haoss]

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

Ok no problem but still thank you and appreciate it

 

[HeinrichPaul]

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.

Hi mumps,
got it done eventually, sorry lot of work in the meantime. Is that below what you'd need?
Here is some overview:

test2.xlsx
	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP											BA	BB
1	Transactiondate	Invoicedate	DateOfSupply	DateOfReceipt	Invoicenumber	Supplierinvoicenumber	Vatcode	Description	Supplierid	Suppliername	Suppliercountry	Suppliervatnumberused	Suppliercountryvatnumberused	Customercountry	Customercountryvatnumberused	Taxablebasis	Valuevat	Totalvalueline	Amountvatdeducted	Exchange_Rate	Taxablebasiscurrency2	Valuevatcurrency2	Totalvaluelinecurrency2	Amountvatdeductedcurrency2	X_BusinessPartnerName	Partner VAT reg. No.											X_Ship_from_country	X_Ship_to_country
2					432567891	PO-1	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	67.59	0.00	67.59	0.00	1	67.59	0.00	67.59	0.00	xyz ltd	IX999999999
3					432567892	PO-2	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	865.33	0.00	865.33	0.00	1	865.33	0.00	865.33	0.00	xyz ltd	IX999999999
4					432567893	PO-3	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	1103.22	0.00	1103.22	0.00	1	1103.22	0.00	1103.22	0.00	xyz ltd	IX999999999
5					432567894	0001/354367/X	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	1532.01	0.00	1532.01	0.00	1	1532.01	0.00	1532.01	0.00	aby gmbh	IF123443434
6					432567895	PO-4	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	1905.15	0.00	1905.15	0.00	1	1905.15	0.00	1905.15	0.00	cdx Limited	ID463241739284
7					432567896	45345344	BD			Wellcork Inc	XY	XY12739718293	XY	Mars	Mars	183.20	0.00	183.20	0.00	0.882	161.59	0.00	161.59	0.00	Xl ltd	CZ3143743984
MOD_IVAT_FORMAT

As the columns are hidden it'd be good to unhide them. Got this bit below, but am not sure how It works to get it added to be honest:

For Each col In ActiveSheet.UsedRange.Columns
If col.Hidden Then col.Hidden = False
Next

KR
Matthias

 

[mumps]

The hidden columns are not showing. I think it would be easier to help if 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.

 

[JustinJ]

I had an extra space in one of the lines. Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    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)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hi mumps,
I have scabbed together a version of your code (from 2015, wow) and I don't know why it is looking for Book1.xlsx at the Set wkbSource line. I was testing source folder locally and it seemed to be working. So, I replaced the local path with the actual path, saved and restarted excel and it doesn't seem to be working now.

Can you advise?

I was hoping to run this as a function from Access.

Sub IRMCARCHIVEMASTERLOOP()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = Workbooks.Open("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\99-DB_Source_Files\999-ARCHIVE_MASTER.xlsx")
    Dim LastRow As Long
    Const strPath As String = "\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\999-Archive\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A2:S2" & LastRow).Copy wkbDest.Sheets("ARCHIVE_MASTER").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Sheets(1).Select
    Range("A2").Value = "1"
    Range("A3").Value = "2"
    Range("A4").Value = "3"
    Range("A2:A4").Select
    Selection.AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
    
    wkbDest.Close savechanges:=True
    
    Application.ScreenUpdating = True
End Sub

 

[mumps]

The code loops through all the files in your "999-Archive" folder. Book1.xlsx must be in that folder.

 

[JustinJ]

If it is in there, I cannot find it. There are 261 files on that folder and they are all named similarly __###Z####-%.xlsx
I used the folder search function for "Book" and no matches were returned.
Could it be a hidden file?

 

[JustinJ]

The code loops through all the files in your "999-Archive" folder. Book1.xlsx must be in that folder.

Okay, so after some trouble shooting, I have discovered that it is not looking for Book1 in the directory. Book1.xlsM (I mistook the M for an X) was the file I was running the macro from earlier.

I renamed Book1.xlsM to Macros.xlsm (this is how I realized the error before was saying it couldnt find Boo1.xlsM).

My goal is to create a macro independent of the master file. I want the macro to open my master file and then loop through a directory containing source files and copy/paste the data to the master.

At this point, I dont know why the macro is looking for its home file.

Sub IRMCARCHIVEMASTERLOOP()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = Workbooks.Open("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\99-DB_Source_Files\999-ARCHIVE_MASTER.xlsx")
    Dim LastRow As Long
    Const strPath As String = "\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\999-Archive\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("*Z*").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("*Z*").Range("A2:S2" & LastRow).Copy wkbDest.Sheets("*MASTER").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Sheets(1).Select
    Range("A2").Value = "1"
    Range("A3").Value = "2"
    Range("A4").Value = "3"
    Range("A2:A4").Select
    Selection.AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
    
    wkbDest.Close savechanges:=True
    
    Application.ScreenUpdating = True
End Sub

 

[JustinJ]

Awesome, I got all three working, I think.

I replaced the Dir("*.xls*") with Dir(source path). Does anyone see any potential issue with this version?

Sub IRMCPREDECESSORMASTERLOOP()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = Workbooks.Open("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\99-DB_Source_Files\20-PREDECESSOR_MASTER.xlsx")
    Dim LastRow As Long
    Const strPath As String = "\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\20-Predecessor\"
    ChDir strPath
    strExtension = Dir("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\20-Predecessor\")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A2:S2" & LastRow).Copy wkbDest.Sheets("PREDECESSOR_MASTER").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Sheets(1).Select
    Range("A2").Value = "1"
    Range("A3").Value = "2"
    Range("A4").Value = "3"
    Range("A2:A4").Select
    Selection.AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
    
    wkbDest.Close savechanges:=True
    
    Application.ScreenUpdating = True
End Sub

 

[GavinAdcock]

This macro was very useful to me. It works seemlessly to copy about 500 lines of data from 15 workbooks. I noticed one issue though, as a few users have added formulae to their data, so I'd like to modify the VBA to copy > paste-values but can't seem to get the syntax right to do that. Can someone help?

 

[mumps]

Try:

Sub IRMCPREDECESSORMASTERLOOP()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = Workbooks.Open("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\99-DB_Source_Files\20-PREDECESSOR_MASTER.xlsx")
    Dim LastRow As Long
    Const strPath As String = "\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\20-Predecessor\"
    ChDir strPath
    strExtension = Dir("\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\20-Predecessor\")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A2:S2" & LastRow).Copy
            wkbDest.Sheets("PREDECESSOR_MASTER").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Sheets(1).Select
    Range("A2").Value = "1"
    Range("A3").Value = "2"
    Range("A4").Value = "3"
    Range("A2:A4").Select
    Selection.AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
    wkbDest.Close savechanges:=True
    Application.ScreenUpdating = True
End Sub