Copy Paste Values from multiple workbooks to multiple sheets in one workbook

[tatendamark]

I have multiple workbooks spanning from "ABC1" to "ABC100", as well as "XYZ1" to "XYZ100" in a folder called "Cases".

I would like to create a "Master" workbook in the folder "Cases", where a code runs that copies values from workbook "ABC1" Cell A1 in Sheet 1, as well as from Cell A1 in Sheet 2, and pastes these as values into "Master" workbook Sheet 1, Cell A1 and Cell A2 respectively. Once completed, sheet 1 in "Master" workbook must then be named "ABC1".

The same must be done for values in workbook "ABC2" to "ABC100", as well as "XYZ1" to "XYZ100". The final result will see "Master" workbook have 200 worksheets/tabs, ranging from "ABC1" to "XYZ100", with each containing a value in Cell A1 and Cell A2.

PS: Each excel workbook is in a different folder in the "Cases" folder. e.g. the "ABC1" workbook is in a folder called "ABC1".

Your assistance is greatly appreciated.

[mdmackillop]

Give this a try

Sub Test()
Dim WBm, WBk, Sht, wsM, Fld, Pth
Dim arr, a, i&
Fld = "F:\Cases"
Pth = Fld & "\*.xls*"


Application.ScreenUpdating = False
Set WBm = Workbooks.Add
WBm.SaveAs Fld & "\Master.xlsx", FileFormat:=xlOpenXMLWorkbook


arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & Pth & """ /b /a-d /s").stdout.readall, vbCrLf), ".")
For Each a In arr
If InStr(1, a, "~") = 0 Then
Set WBk = Workbooks.Open(a)
If WBk.Name <> ThisWorkbook.Name And InStr(1, WBk.Name, "Master") = 0 Then
i = 0
Set wsM = WBm.Sheets.Add(after:=WBm.Sheets(WBm.Sheets.Count))
wsM.Name = Split(a, "\")(2)
For Each Sht In WBk.Worksheets
i = i + 1
wsM.Cells(1, 1).Offset(, i - 1) = Sht.Cells(1, 1)
Next Sht
WBk.Close False
End If
End If
Next
WBm.Close True
Application.ScreenUpdating = True
End Sub

[tatendamark]

Awesome! I have just tried running the code. Just a few queries:
1. It breaks at this point: wsM.Name = Split(a, "\")(2)
2. What does this line do?:
arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & Pth & """ /b /a-d /s").stdout.readall, vbCrLf), ".")
3. If the workbooks are macro enabled and have links, is the a line code that can be used to automatically disable the macros and ignore the notification for updating the links?
4.What if I have the workbook "ABC1" (and multiple workbooks like this), and I want to copy and paste specific values to specific cells in the "Master" workbook e.g. in workbook "ABC1", I want to copy values in worksheet 'Name'!A3, as well as column 'Date of Birth'!E2:E100, into "Master" workbook Sheet1!A2 and Sheet1!A3:A101, respectively.

Just a bit under time pressure, but I will work on the above code in the mean time to see if I can solve the above as well.

Thank you for your help. Much appreciated.

[mdmackillop]

1) Added line
If UBound(Split(a, "\")) = 3 Then
wsM.Name = Split(a, "\")(2) - This should return ABC from F:\Cases\ABC\ABC.xlsx
If your folder structure is different, change these to suit

2) Added line
Application.EnableEvents = False
Amended line
Set WBk = Workbooks.Open(Filename:=a, UpdateLinks:=False)

3) Possible but coding depends upon the consistency of your files. Does every single one contain Name and Date of Birth sheets?


Sub Test() Dim WBm, WBk, Sht, wsM, Fld, Pth
Dim arr, a, i&
Fld = "F:\Cases"
Pth = Fld & "\*.xls*"


Application.ScreenUpdating = False
Application.EnableEvents = False
Set WBm = Workbooks.Add
WBm.SaveAs Fld & "\Master.xlsx", FileFormat:=xlOpenXMLWorkbook

arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & Pth & """ /b /a-d /s").stdout.readall, vbCrLf), ".")
For Each a In arr
If UBound(Split(a, "\")) = 3 Then
If InStr(1, a, "~") = 0 Then
Set WBk = Workbooks.Open(Filename:=a, UpdateLinks:=False)
If WBk.Name <> ThisWorkbook.Name And InStr(1, WBk.Name, "Master") = 0 Then
i = 0
Set wsM = WBm.Sheets.Add(after:=WBm.Sheets(WBm.Sheets.Count))
wsM.Name = Split(a, "\")(2)
For Each Sht In WBk.Worksheets
i = i + 1
wsM.Cells(1, 1).Offset(, i - 1) = Sht.Cells(1, 1)
Next Sht
WBk.Close False
End If
End If
End If
Next
WBm.Close True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

[tatendamark]

This is very helpful.

I have changed code to wsM.Name = Split(a, "\")(3) to look into C:\Cases\ABC\ABC1\ABC1.xlsx etc.

A few more questions:
1. Some of the folders contain more than one excel file e.g. C:\Cases\ABC\ABC1\ could have ABC1.xlsx, as well as ABC1r1.xlsx. I would probably think its best to name the sheets in the "Master" workbook after the workbooks, rather than naming the sheets after folder e.g. sheet names would be ABC1 and ABC1r1.
2. Possible but coding depends upon the consistency of your files. Does every single one contain Name and Date of Birth sheets?:

Here is where it gets a bit tricky. I hope I can explain this well. All the files are either in relation to Date of births or Date of deaths. All files have a "Name" worksheet/tab, and either "Date of Birth" or "Date of Death" worksheet/tab.
A. For the files with the "Date of Birth" sheet, I need to copy Column 'Date of Birth'!E2:E100.B. For the files with the "Date of Death" sheet, I need to copy Column 'Date of Death'!B2:E100.

Apart from the difference in the name of the worksheet/tab, Cell 'Name'!B19 can be used to distinguish between the "Date of Birth" workbooks and the "Date of Death" workbooks. 'Name'!B19 is empty for all files related to Date of Death, but contains a value for all files related to Date of Birth.

For now, all data can be captured in the "Master" workbook.

[mdmackillop]

Can you post a couple of workbooks with sensitive data removed?

[tatendamark]

I have attached simple versions of what the sheets look like. The master sheet is just an example of what the data will look like.

Is there a line of code that allows the code to run should it encounter errors e.g. a random or corrupt excel file, which contains no data?

Thanx for taking time to assist.

[mdmackillop]

No simple way to handle errors. You could use "On Error Resume Next" but you should really identify issues and deal with them.
Try this

Sub Test() Dim WBm, WBk, Sht, wsM, Fld, Pth, Nm
Dim arr, a, i&
Fld = "F:\Cases"
Pth = Fld & "\*.xls*"


Application.ScreenUpdating = False
Application.EnableEvents = False
Set WBm = Workbooks.Add
WBm.SaveAs Fld & "\Master.xlsx", FileFormat:=xlOpenXMLWorkbook

arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & Pth & """ /b /a-d /s").stdout.readall, vbCrLf), ".")
For Each a In arr
If UBound(Split(a, "\")) = 3 Then
If InStr(1, a, "~") = 0 Then
Set WBk = Workbooks.Open(Filename:=a, UpdateLinks:=False)
If WBk.Name <> ThisWorkbook.Name And InStr(1, WBk.Name, "Master") = 0 Then
i = 0
Set wsM = WBm.Sheets.Add(after:=WBm.Sheets(WBm.Sheets.Count))
'Sheet name from file '@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Nm = Split(a, "\")(UBound(Split(a, "\")))
Nm = Left(Nm, InStrRev(Nm, ".") - 1)
wsM.Name = Nm
For Each Sht In WBk.Worksheets
Select Case Sht.Name
'Check these are correct @@@@@@@@@@@@@@@@@@@@@
Case "Name"
wsM.Sheet1.Cells(2, 1) = Sht.Range("A3")
Case "Date of Birth"
wsM.Sheet1.Cells(1, 1) = "Employee Name"
wsM.Sheet1.Cells(3, 1) = "Date of births captured"
Sht.Range("E2:E100").Copy wsM.Sheet1.Cells(4, 1)
Case "Date of Death"
wsM.Sheet1.Cells(1, 1) = "Employee Name"
wsM.Sheet1.Cells(3, 1) = "Date of deaths captured"
Sht.Range("B2:B100").Copy wsM.Sheet1.Cells(4, 1)
End Select
'i = i + 1
'wsM.Cells(1, 1).Offset(, i - 1) = Sht.Cells(1, 1)
Next Sht
WBk.Close False
End If
End If
End If
Next
WBm.Close True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

[tatendamark]

So I am getting this error:

Excel VBA: Run-time error '438' Object doesn't support this property or method

on this line: wsM.Sheet1.Cells(2, 1) = Sht.Range("A3")

Do I need to specify the workbook as well in "Sht.Range("A3")"?

[mdmackillop]

Sorry, wsM is the worksheet so:

For Each Sht In WBk.Worksheets
Select Case Sht.Name
'Check these are correct @@@@@@@@@@@@@@@@@@@@@
Case "Name"
wsM.Cells(2, 1) = Sht.Range("A3").Value
Case "Date of Birth"
wsM.Cells(1, 1) = "Employee Name"
wsM.Cells(3, 1) = "Date of births captured"
Sht.Range("E2:E100").Copy wsM.Cells(4, 1)
Case "Date of Death"
wsM.Cells(1, 1) = "Employee Name"
wsM.Cells(3, 1) = "Date of deaths captured"
Sht.Range("B2:B100").Copy wsM.Cells(4, 1)
End Select
'i = i + 1
'wsM.Cells(1, 1).Offset(, i - 1) = Sht.Cells(1, 1)
Next Sht

[tatendamark]

All good. It works well now. Life saver! Thank you (on loop :friends:).