Vba code to copy and paste dynamic range from mulitple workbooks to one workbook

[Oran]

Hi

Please help

I have multiple workbooks in the same folder:
-Workbook 1 -Sheet(Alice)
-Workbook 2-Sheet(Mop)
-Workbook 3-Sheet(Khan)
All sheets have the same column headings but These sheets have dynamic ranges(number of records vary).

Destination workbook: is called Final With sheet "Data"

1. I want to copy sheet Alice,Mop, Khan and paste it below one another in my final workbook(data)
2. if i press the button again, it should clear and repeat step 1
3. I want to store the name of the sheet i am copying into column F of my final workbook. for example if alice records are in rows 1-50. column f, rows 1-50 should have alice written and so on.

[paulked]

Clunky, but it works!

Sub GetData()
    Dim tbl As ListObject
    Dim wb As Workbook
    Dim i As Long, j As Long, rw As Long, lr As Long
    Application.ScreenUpdating = False
    Set tbl = ActiveSheet.ListObjects("Table1")
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
    End With
    tbl.DataBodyRange.Rows(1).ClearContents
    rw = 2
    For i = 1 To 3
        Set wb = Workbooks.Open("Workbook" & i & ".xlsm")
        Select Case i
            Case 1
                lr = Workbooks("Workbook1").Sheets("Alice").Cells(Rows.Count, 1).End(xlUp).Row
                Workbooks("Workbook1").Sheets("Alice").Range("A2:E" & lr).Copy Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 1)
                For j = 2 To lr
                    Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 6) = "Alice"
                    rw = rw + 1
                Next
            Case 2
                lr = Workbooks("Workbook2").Sheets("Mop").Cells(Rows.Count, 1).End(xlUp).Row
                Workbooks("Workbook2").Sheets("Mop").Range("A2:E" & lr).Copy Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 1)
                For j = 2 To lr
                    Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 6) = "Mop"
                    rw = rw + 1
                Next
            Case 3
                lr = Workbooks("Workbook3").Sheets("Khan").Cells(Rows.Count, 1).End(xlUp).Row
                Workbooks("Workbook3").Sheets("Khan").Range("A2:E" & lr).Copy Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 1)
                For j = 2 To lr
                    Workbooks("Final.xlsm").Sheets("Data").Cells(rw, 6) = "Khan"
                    rw = rw + 1
                Next
        End Select
        Workbooks("Workbook" & i & ".xlsm").Close
    Next
    Application.ScreenUpdating = True
End Sub

[Oran]

Thank you it works

[paulked]

Use 'Thread Tools' at the top of the thread to mark it solved

[jolivanes]

I know paulked set you up so you don't really need another one to overload your mind but hey, you might want to run one and later the other one!
It does need the workbook with the code ("Final.xlsm") and the three other workbooks to be in the same folder.
It also assumes that you have headers in all sheets.
Extend the array to however many books/sheets you want. I am sure you see the relation.
Change wb names etc if and where required.

Sub Oran()
Dim wbshArr, wb As Workbook, i As Long, lc As Long, lr As Long
Application.ScreenUpdating = False
wbshArr = Array("Oran_Workbook_1", "Alice", "Oran_Workbook_2", "Mop", "Oran_Workbook_3", "Khan")
    For i = LBound(wbshArr) To UBound(wbshArr) - 1 Step 2
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & wbshArr(0) & ".xlsm")
        With wb.Sheets(wbshArr(i + 1))
            lc = .UsedRange.Columns.Count
            lr = .UsedRange.Rows.Count
            .Range(.Cells(2, 1), .Cells(lr, lc)).Copy ThisWorkbook.Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End With
    wb.Close False
    Sheets("Data").Cells(Rows.Count, 6).End(xlUp).Offset(1).Resize(lr - 1).Value = wbshArr(i + 1)
    Next i
Application.ScreenUpdating = True
End Sub

BTW, for the clearing of data on the "Data" sheet, insert this line after the "ScreenUpdating = False" line.

Sheets("Data").UsedRange.Offset(1).ClearContents

[paulked]

Much neater Told ya mine was 'Clunky'!

[jolivanes]

Does not matter in many cases how you get to the end as long as you get there.

[akocak4]

There is a mistake in the program:


In the line: Set wb = Workbooks.Open(ThisWorkbook.Path & "" & wbshArr(0) & ".xlsm")


should be "wbshArr(i)".


Also the below line can be deleted: Sheets("Data").Cells(Rows.Count, 6).End(xlUp).Offset(1).Resize(lr - 1).Value = wbshArr(i + 1) Thank you jolivanes. Nice Program.

[jolivanes]

Re: "There is a mistake in the program:"
The joys of testing and not changing!
Thanks for being on the ball.

The line that you figure can be deleted puts the sheet name where Oran requested it.

You can try this also. Not much difference though.

Sub AAAAB_2()
Dim wbshArr, wb As Workbook, i As Long, lc As Long, lr As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = ThisWorkbook.Sheets("Data")
wbshArr = Array("Oran_Workbook_1", "Alice", "Oran_Workbook_2", "Mop", "Oran_Workbook_3", "Khan")
    For i = LBound(wbshArr) To UBound(wbshArr) - 1 Step 2
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & wbshArr(i) & ".xlsm")
        wb.Sheets(wbshArr(i + 1)).UsedRange.Offset(1).Copy ThisWorkbook.Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        sh1.Range("Q" & sh1.Cells(Rows.Count, 17).End(xlUp).Offset(1).Row & ":Q" & sh1.Cells(Rows.Count, 1).End(xlUp).Row).Value = wbshArr(i + 1)
    wb.Close False
    Next i
Application.ScreenUpdating = True
End Sub