VBA code to copy data from multiple workbooks to a sheet in a master wb.

Ninja_nutter

New Member
Joined
Mar 1, 2016
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hi All,
I have 10 workbooks and a Master workbook in a folder, that I have adapted some code, to copy the data from a named sheet "Action Log" in each source wb to the master wb then loop through to the next wb.
On the master wb sheet column "A" needs to show which wb the data came from by copy/pasting the valve of cell "E1" from the source wb.
The problem I cannot solve is how to make the autofill destination range dynamic.
Any assistance with this problem will be greatly appreciated.

VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim lRow As Long
    Dim last_row As Long
    Dim my_Range As Range
    
    
    Set wkbDest = ThisWorkbook
    Const strPath As String = "H:\2021 new version\" 'Folder path for all workbooks
    ChDir strPath
    strExtension = Dir("*.xlsm*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Sheets("Action Log").Select
            Cells(Rows.Count, 2).End(xlUp).Select
            lr = ActiveCell.Offset(0, 0).Select
            Range(ActiveCell, "N8").Copy
            .Sheets("Action Log").Range("B8:N" & Range("A" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Action Log").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Sheets("Action Log").Range("E1").Copy 'workbook title to be copied to column A of the master workbook for each row of data copied over
            wkbDest.Sheets("Action Log").Activate
            
            lRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                        ActiveCell.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, SkipBlanks:=False, Transpose:=False ' pastes the value of E1 to the first blank cell in column A
            Application.CutCopyMode = False
            last_row = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
        Set my_Range = ActiveSheet.Range("A8:A" & last_row) 
        Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Select
        Selection.Copy
        Selection.AutoFill Destination:=Range("A8:A" & last_row) 'This is where I cannot workout how to make this range dynamic after the first wb data has been copied. 
        
        
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,725
Office Version
  1. 2010
Platform
  1. Windows
According to your zip source data workbooks can you explain at least from which one come rows #8 to 10 in your expected result workbook ?​
As if I can't reproduce the same expected result I won't waste any time to write even a single VBA codeline !​
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

Ninja_nutter

New Member
Joined
Mar 1, 2016
Messages
21
Office Version
  1. 365
Platform
  1. Windows
According to your zip source data workbooks can you explain at least from which one come rows #8 to 10 in your expected result workbook ?​
As if I can't reproduce the same expected result I won't waste any time to write even a single VBA codeline !​
Hi Marc,

I appreciate you taking the time. The original code was incorrect!! In that I had to adjust the merged columns.

VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim lRow As Long
    Dim last_row As Long
    Dim my_Range As Range
    
    
    Set wkbDest = ThisWorkbook
    Const strPath As String = "U:\My Documents\Continuous Improvement\5S\2021 new version\" '"H:\Suffolk EfW\1. Management System & Forms\1.6 Continuous Improvement\5S\2021 new version\" 'Folder path for all workbooks
    ChDir strPath
    strExtension = Dir("*.xlsm*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Sheets("Action Log").Select 'Named worksheet in each workbook to be opened.
            Cells(Rows.Count, 2).End(xlUp).Select 'Select data range to be copied from colum B last row to G8
            lr = ActiveCell.Offset(0, 0).Select
            Range(ActiveCell, "G8").Copy
            .Sheets("Action Log").Range("B8:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Action Log").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Sheets("Action Log").Range("C1").Copy ' Workbook title to be copied over to column A of the results book against each line entry of data.
            wkbDest.Sheets("Action Log").Activate
            
            lRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                        ActiveCell.PasteSpecial Paste:=xlPasteValues
            last_row = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
        Set my_Range = ActiveSheet.Range("A8:A" & last_row) ' finds first empty cell for the source title to be pasted into
        Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Select
        Selection.Copy
        Selection.AutoFill Destination:=Range("A8:A" & Range("B" & Rows.Count).End(xlUp).Row) ' finds first empty cell for the source title to be pasted into.  This is where the macro stops in the loop on the second source work book as the range starting cell would be A11
Range(Selection, Selection.End(xlDown)).Select
        
        
            .Close savechanges:=False ' closes soource workbook without closing
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,725
Office Version
  1. 2010
Platform
  1. Windows
Should we understand that it's solved ?​
In negative case so just link an accurate expected result workbook accordingly with your source workbooks from the original attachment …​
 

Forum statistics

Threads
1,148,007
Messages
5,744,319
Members
423,861
Latest member
Ka3EeM

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top