How to paste from multiple Excel workbooks into one workbook (Across the page & file names)
Category: [Excel] Demo Available
How to paste from multiple Excel workbooks into one workbook (Across the page & file names)
Requirement:
have a folder and in that folder are a number of Excel workbooks. For this task I need to be able to consolidate the data from a range of cells in a particular worksheet (called Appendix B in each one) in these workbooks into one worksheet called Master (in a separate workbook). This is what I have so far in terms of code, and it works great.
Code
Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Const strPath As String = "C:\Users\cmarsh\Desktop\group_1"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
LastRow = .Sheets("Appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Appendix B").Range("A1:D" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub
Result example
However I want to expand on this so that instead of the data going down the page it goes horizontally across the page, I also want to add the source workbook name to the top of each section, please see an example below;
Required result example
[IMG]file:///C:/Users/cmarsh/AppData/Local/Temp/msohtmlclip1/01/clip_image003.jpg[/IMG]
Solution:
Code:
Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Const strPath As String = "C:\Users\cmarsh\Desktop\group_1\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
Application.ScreenUpdating = True
With wkbSource
LastRow = .Sheets("Appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rLastCell As Range
Dim rwkbSourceLastCell As Range
Set rLastCell = wkbDest.Sheets("Master").Cells.Find(What:="*", After:=wkbDest.Sheets("Master").Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If rLastCell Is Nothing Then Set rLastCell = wkbDest.Sheets("Master").Cells(1, 1)
wkbDest.Sheets("Master").Cells(2, rLastCell.Column).Offset(-1, 1).Value = wkbSource.Name
Set rwkbSourceLastCell = .Sheets("Appendix B").Cells.Find(What:="*", After:=.Sheets("Appendix B").Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
wkbDest.Sheets("Master").Cells(2, rLastCell.Column + 1).Resize(LastRow, rwkbSourceLastCell.Column).Value = .Sheets("Appendix B").Cells(1, 1).Resize(LastRow, rwkbSourceLastCell.Column).Value
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub
Obtained from the OzGrid Help Forum.
Solution provided by Gizzmo
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to copy and paste when criteria is met |
| How to paste a cell value to the active cell |
| How to paste value when creating a master summary sheet |
| How to copy the entire sheet and paste as values - running on multiple tabs |
| How to copy and paste column in wkbk 1 if its cell has text which matches with a cell of wbk 2 |
|
How to copy the data from sheet 1 and paste the data to sheet 2 each first empty row of each row |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.