VBA code to copy range in multiple workbook, paste to master workbook contain sheets according to range value copied

[rozek]

Hi. Appreciate any help. Need a VBA code to copy paste sheet.range value FROM multiple workbooks (same table format in each sheet) located in same folder TO multiple worksheets in a master workbook. These worksheets in the master workbook are named with same name as the variable in the copy value. For clarity :

workbook1 (01012021.xlsx)

01012021.xlsx
	A	B	C	D
1	NAME	DATE	P	T
2	NAME1	1/1/2021	100	300
3	NAME2	1/1/2021	2	2
SOURCE

workbook2 (02012021.xlsx)

02012021.xlsx
	A	B	C	D
1	NAME	DATE	P	T
2	NAME1	2/1/2021	300	300
3	NAME2	2/1/2021	3	3
SOURCE

User will run the macro from Master workbook following these steps:
1. Choose folder path to the source workbooks (01012021.xlsx & 02012021.xlsx) as per above.
2. Do for workbook1 first. Copy sheet.range (A2:D2) which has the values for NAME1.
3. Pasting that copied sheet.range value to master workbook accordingly to the worksheet NAME1
4. Do again for next row copy sheet.range (A3:D3) which has the values for NAME2.
5. Pasting that copied sheet.range value to master workbook accordingly to the worksheet NAME2
6. Closed workbook1, activate workbook2
7. Repeat same process as step 2 to 5 pasting in master workbook accordingly.

The final result in Master workbook will be like below for sheet NAME1

Master.xlsm
	A	B	C	D
1	NAME	DATE	P	T
2	NAME1	1/1/2021	100	300
3	NAME1	2/1/2021	300	300
NAME1

and for sheet NAME2 as below

Master.xlsm
	A	B	C	D
1	NAME	DATE	P	T
2	NAME2	1/1/2021	2	2
3	NAME2	2/1/2021	3	3
NAME2

I will be glad to answer any question for further understanding. Thank you for your help.

 

[Marc L]

Hi,​

​

is step #1 really necessary if the folder path is always the same ?​

 

[rozek]

Hi,​

​

is step #1 really necessary if the folder path is always the same ?​

Thank you Marc for the reply. It's not needed but good to have for audit purposes. Appreciate your help.

 

[Marc L]

According to your attachment a VBA demonstration for starters :​

Sub Demo1()
        Dim P$, F$, E$, N&, oADO(1) As Object, S$, V(), C%
    With Application.FileDialog(msoFileDialogFolderPicker)
       .InitialFileName = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, .Parent.PathSeparator))
        If .Show Then P = .SelectedItems(1) & .Parent.PathSeparator Else Exit Sub
    End With
        F = Dir$(P & "*.xlsx"):  If F = "" Then Beep: Exit Sub
        E = "Excel 12.0"
    With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
        For N = Sheets.Count To 2 Step -1:  Sheets(N).Delete:  Next
        With Sheets(1):  .Name = .CodeName:  .UsedRange.Clear:  End With
    Set oADO(0) = CreateObject("ADODB.Connection")
        oADO(0).Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""" & E & """;Data Source=" & P & F
        E = "' '" & E & ";'"
        S = "SELECT * FROM [SOURCE$]"
        P = " UNION ALL " & S & " IN '" & P
        F = Dir$
        While F > "":  S = S & P & F & E:  F = Dir$:  Wend
    Set oADO(1) = CreateObject("ADODB.Recordset")
        oADO(1).Open S, oADO(0), 1
   With oADO(1).Fields
        ReDim V(.Count - 1)
        For N = 0 To .Count - 1:  V(N) = .Item(N).Name:  Next
        [A1].Resize(, .Count).Value2 = V
   End With
        [A2].CopyFromRecordset oADO(1)
        oADO(1).Close:  oADO(0).Close:  Erase oADO
    With [A1].CurrentRegion.Columns
        If .Rows.Count > 1 Then
            C = .Count + 3
           .Item(1).AdvancedFilter 2, , .Cells(1, C), True
           .Cells(1, C).CurrentRegion.Sort .Cells(1, C), 1, Header:=1
            V = .Cells(1, C).CurrentRegion.Value2
        For N = 2 To UBound(V)
            Sheets.Add(, ActiveSheet).Name = V(N, 1)
           .Cells(2, C).Value2 = V(N, 1)
           .AdvancedFilter 2, .Cells(1, C).Resize(2), [A1]
        Next
           .Parent.Delete
        End If
    End With
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub

 

[rozek]

According to your attachment a VBA demonstration for starters :​

Sub Demo1()
        Dim P$, F$, E$, N&, oADO(1) As Object, S$, V(), C%
    With Application.FileDialog(msoFileDialogFolderPicker)
       .InitialFileName = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, .Parent.PathSeparator))
        If .Show Then P = .SelectedItems(1) & .Parent.PathSeparator Else Exit Sub
    End With
        F = Dir$(P & "*.xlsx"):  If F = "" Then Beep: Exit Sub
        E = "Excel 12.0"
    With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
        For N = Sheets.Count To 2 Step -1:  Sheets(N).Delete:  Next
        With Sheets(1):  .Name = .CodeName:  .UsedRange.Clear:  End With
    Set oADO(0) = CreateObject("ADODB.Connection")
        oADO(0).Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""" & E & """;Data Source=" & P & F
        E = "' '" & E & ";'"
        S = "SELECT * FROM [SOURCE$]"
        P = " UNION ALL " & S & " IN '" & P
        F = Dir$
        While F > "":  S = S & P & F & E:  F = Dir$:  Wend
    Set oADO(1) = CreateObject("ADODB.Recordset")
        oADO(1).Open S, oADO(0), 1
   With oADO(1).Fields
        ReDim V(.Count - 1)
        For N = 0 To .Count - 1:  V(N) = .Item(N).Name:  Next
        [A1].Resize(, .Count).Value2 = V
   End With
        [A2].CopyFromRecordset oADO(1)
        oADO(1).Close:  oADO(0).Close:  Erase oADO
    With [A1].CurrentRegion.Columns
        If .Rows.Count > 1 Then
            C = .Count + 3
           .Item(1).AdvancedFilter 2, , .Cells(1, C), True
           .Cells(1, C).CurrentRegion.Sort .Cells(1, C), 1, Header:=1
            V = .Cells(1, C).CurrentRegion.Value2
        For N = 2 To UBound(V)
            Sheets.Add(, ActiveSheet).Name = V(N, 1)
           .Cells(2, C).Value2 = V(N, 1)
           .AdvancedFilter 2, .Cells(1, C).Resize(2), [A1]
        Next
           .Parent.Delete
        End If
    End With
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub

Thank You Marc for the code. I'm struggling a bit to understand your coding. Its not the 'normal' straight forward excel vba code for a beginner like me. Anyway let me give it a try and reply with a feedback. Thanks again

 

[rozek]

Hi Marc. The VBA code works fine. Just need to understand what to add/edit if:
1. To add a command BUTTON on click to run the macro. When I created a new sheet in Master workbook to add in the command button, the sheet disappeared once I press run. Remaining sheets are the original sheets NAME1 & NAME2 only. How to disable this so that the macro wont delete any new sheet created in the Master workbook.

2. If I add more columns to the source sheets (column R, S), which part in the code I need to tweak so that it will pick this up too when pasting.

01012021.xlsx
	A	B	C	D	E	F
1	NAME	DATE	P	T	R	S
2	NAME1	1/1/2021	100	300	apple	orange
3	NAME2	1/1/2021	2	2	manggo	apple
SOURCE

3. When I change the values in the columns to non integer value, the pasting column showed blank. Where should I change this for the pasting to work with character value.

 

[Marc L]

It's a faster way than the classic slowest way as you described …​

​

1. Just remove the Delete codeline near the end of the procedure, the button must be located in the first sheet …​

​

2. No need any mod with smart design worksheet only !​

​

3. No issue on my side so zip some source files and link the zip file on a files host website like Dropbox …​

 

[rozek]

hi Marc, Just wanted to ask if I were to have multiple workbooks as source data, how would this code handle the pasting to the new row below the existing row. I guess need to use looping of some sort. Hope you can help. Thank you again

 

[Marc L]

​

As your initial post contains multiple source data workbooks so my demonstration already works for this context …​