Help!! Merging multiple Excel workbooks into one master sheet.

[MXCG2016]

Hi All,

I have been researching online and found a piece of VBA code which I have edited to match my needs (working). The code is setup to look at a folder location and merge all excel .xlsx files into a master sheet. However, I am having difficulty amending the code to only read and copy a specific sheet from the source files. I only need to copy one specific sheet ("Sheet2") from each file :-). Appreciate the help:



Sub simpleXlsMerger()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
Dim wrksht As String

wrksht = "Test"
Set dirObj = mergeObj.Getfolder("\C:\D (file://\\C$\D)")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("D2:Z" & Range("D65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Master").Activate
Range("A85536").End(xlUp).Offset(2, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub

Thanks

[mana]

Worksheets("Sheet2").Range("D2:Z" & Worksheets("Sheet2").Range("D65536").End(xlUp).Row).Copy

[MXCG2016]

Hi Mana, Thanks for your reply :-). Unfortunately the code doesn't work, I can't seem to work out what is wrong. Any ideas? Many Thanks

[MXCG2016]

Hi Mana, It appears that your line of code only copies data from the current workbook and not the remote files listed in the C:\D location. Any ideas on how o amend the code to copy data from the source files ("Sheet2"). Thanks

[Paul_Hossler]

1. Not sure about


Set dirObj = mergeObj.Getfolder("\C:\D (file://c%24/D)")


2. Not sure about apparently leaving blank lines (so I didn't)




Option Explicit


Sub simpleXlsMerger()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim wrksht As String
Dim iLast As Long, i As Long
Dim rSrc As Range, rDest As Range

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")

wrksht = "Test"

Set dirObj = mergeObj.Getfolder("D:\Test")
Set filesObj = dirObj.Files

For Each everyObj In filesObj

If everyObj.Name = ThisWorkbook.Name Then GoTo NextWorkbook
If Left(everyObj.Name, 2) = "~$" Then GoTo NextWorkbook
If UCase(Right(everyObj.Name, 4)) <> "XLSX" Then GoTo NextWorkbook


Set bookList = Workbooks.Open(everyObj)

i = -1
On Error Resume Next
i = bookList.Worksheets("Sheet2").Index
On Error GoTo 0

If i = -1 Then GoTo NoSheet2

With bookList.Worksheets("Sheet2")
iLast = .Cells(.Rows.Count, 4).End(xlUp).Row

Set rSrc = .Range("D2:Z" & iLast)
End With

With ThisWorkbook.Worksheets("Master")
iLast = .Cells(.Rows.Count, 1).End(xlUp).Row

If iLast <> 1 Then
Set rDest = .Cells(iLast + 1, 1)
Else
Set rDest = .Cells(iLast, 1)
End If
End With

rSrc.Copy

ThisWorkbook.Activate
Worksheets("Master").Activate
rDest.Select
Selection.PasteSpecial

Application.CutCopyMode = False

NoSheet2:
bookList.Close


NextWorkbook:
Next


ThisWorkbook.Activate

MsgBox "Done"


End Sub



Little short on comments, but you should be able to figure it out. If not, feel free to ask questions

[MXCG2016]

Hi Paul,

That's brilliant - the code does exactly what I require. Thanks a lot for your help and for taking the time to share your code. Much appreciated - Headache over :-). I'll mark this as "Solved"