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

[Ninja_nutter]

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.

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]

​

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 !​

 

[Ninja_nutter]

​

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.

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]

​

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 …​