PDA

View Full Version : [SOLVED] Vba code to copy and paste dynamic range from mulitple workbooks to one workbook



Oran
05-07-2019, 02:06 AM
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
05-08-2019, 02:13 PM
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
05-10-2019, 01:06 AM
Thank you it works:)

paulked
05-10-2019, 06:11 AM
Use 'Thread Tools' at the top of the thread to mark it solved :wink:

jolivanes
05-11-2019, 06:44 PM
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
05-11-2019, 10:14 PM
Much neater :thumb Told ya mine was 'Clunky'!

jolivanes
05-12-2019, 09:16 AM
Does not matter in many cases how you get to the end as long as you get there.

akocak4
05-17-2019, 03:08 AM
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
05-17-2019, 12:22 PM
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