VBA copying data from multiple workbooks and worksheets to a Master worksheet

sushil84p

New Member
Joined
Mar 30, 2021
Messages
1
Office Version
  1. 2013
Platform
  1. Windows
VBA copying data from multiple workbooks and worksheets to a Master worksheet

I was successful in copying data from multiple workbooks which had the same headers using the below VBA code but received data into multiple worksheets which I want on a single worksheet as a "Master Consolidated" one.

Sub mergeFiles()
'Merges all files in a folder to a main file.

'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count

'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)

Set sourceWorkbook = ActiveWorkbook

'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy After:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet

'Close the source workbook
sourceWorkbook.Close
Next i

End Sub




******Please Help*****
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
3,650
Office Version
  1. 365
Platform
  1. Windows
Do you want to include an XL2BB copy of one or your source workbooks and of the Master sheet ?
This line is copying the whole sheet into the Master Workbook.
tempWorkSheet.Copy After:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Appending just the data is a bit more involved since you need to keep work out the data range of the source workbook's data and what row you are up to in the Master Data Worksheet.
 

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
178
Office Version
  1. 365
Platform
  1. Windows
VBA copying data from multiple workbooks and worksheets to a Master worksheet

I was successful in copying data from multiple workbooks which had the same headers using the below VBA code but received data into multiple worksheets which I want on a single worksheet as a "Master Consolidated" one.

Sub mergeFiles()
'Merges all files in a folder to a main file.

'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count

'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)

Set sourceWorkbook = ActiveWorkbook

'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy After:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet

'Close the source workbook
sourceWorkbook.Close
Next i

End Sub




******Please Help*****

sushil84p,​

Did you get a solution? I had exactly the same issue and I got the solution right here in this forum! What I dont know is the FORUM POLICY if it allows me to give you the solution. Perhaps an ADMIN can guide us here since I can see you are also new like me?
 

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
3,650
Office Version
  1. 365
Platform
  1. Windows

sushil84p,​

Did you get a solution? I had exactly the same issue and I got the solution right here in this forum! What I dont know is the FORUM POLICY if it allows me to give you the solution. Perhaps an ADMIN can guide us here since I can see you are also new like me?

Most of us answering are volunteers, so if you have a suggestion, go for it and post it !
 

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
178
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Most of us answering are volunteers, so if you have a suggestion, go for it and post it !
Here is the solution. My headers are on row 1 and 2. Code picks the headers from the first Workbook, Worksheet "Master" then it appends the data from row 3 of every Workbook (Sheets.("Master") until the last Workbook in the folder. Try it out! I have numbered the lines for ease of discussion.

====================================
  1. 'Code courtesy of maabadi, of Mrexcel.com forum
  2. Sub ImportFiles3()
  3. Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
  4. Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
  5. Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
  6. Dim os As Long, LrS As Long, LCS As Long, FileName As String
  7. On Error Resume Next
  8. Set xTWB = ThisWorkbook
  9. Worksheets.Add
  10. Set DestSheet = xTWB.ActiveSheet

  11. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
  12. With fldr
  13. .Title = "Select a Folder containing files to merge"
  14. .AllowMultiSelect = False
  15. '.InitialFileName = Application.DefaultFilePath
  16. If .Show <> -1 Then GoTo NextCode
  17. sItem = .SelectedItems(1)
  18. End With
  19. NextCode:

  20. FolderName = sItem
  21. Set fldr = Nothing
  22. FolderPath = FolderName & "\"
  23. FileName = Dir(FolderPath & "*.xls*")
  24. Application.ScreenUpdating = False
  25. Application.Calculation = xlCalculationManual
  26. Application.DisplayAlerts = False
  27. Do While FileName <> ""
  28. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
  29. xStrAWBName = ActiveWorkbook.Name
  30. For Each xWS In ActiveWorkbook.Sheets
  31. If xWS.Name = "Master" Then
  32. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
  33. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
  34. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  35. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  36. If Lr = 1 Then
  37. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
  38. DestSheet.Range("A1").Value = "FileName"
  39. End If
  40. Set Head = xWS.Range("A1")
  41. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
  42. On Error Resume Next
  43. Header = 0
  44. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
  45. On Error GoTo 0
  46. If Header = 0 Then
  47. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
  48. Header = LCD
  49. LCD = LCD + 1
  50. End If
  51. If Lr = 1 Then
  52. Range(DestSheet.Cells(Lr + 2, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  53. Else
  54. Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 2, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  55. End If
  56. Next os
  57. If Lr = 1 Then
  58. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  59. Else
  60. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  61. End If
  62. End If
  63. Next xWS
  64. Workbooks(xStrAWBName).Close
  65. FileName = Dir()
  66. Loop

  67. DestSheet.Activate
  68. DestSheet.Name = "xStrAWBName"
  69. Rows("2:2").Select
  70. Selection.AutoFilter
  71. ActiveWindow.FreezePanes = True
  72. Columns("A:EA").EntireColumn.AutoFit

  73. xTWB.Save
  74. Application.StatusBar = False
  75. Sheets("xStrAWBName").Select
  76. Sheets("xStrAWBName").Move
  77. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False


  78. Application.ScreenUpdating = True
  79. Application.DisplayAlerts = True
  80. Application.Calculation = xlCalculationAutomatic
  81. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
  82. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
  83. End Sub
  84. ==========================================================
I wish it could automatically save the file at LINE 83 as the FolderNAME.CSV.
 
Last edited by a moderator:

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
178
Office Version
  1. 365
Platform
  1. Windows
You will want to remove Line 80 to 83 because, unlike me, you do not need a CSV file.
 

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
178
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Here is the solution. My headers are on row 1 and 2. Code picks the headers from the first Workbook, Worksheet "Master" then it appends the data from row 3 of every Workbook (Sheets.("Master") until the last Workbook in the folder. Try it out! I have numbered the lines for ease of discussion.

====================================
  1. 'Code courtesy of maabadi, of Mrexcel.com forum
  2. Sub ImportFiles3()
  3. Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
  4. Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
  5. Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
  6. Dim os As Long, LrS As Long, LCS As Long, FileName As String
  7. On Error Resume Next
  8. Set xTWB = ThisWorkbook
  9. Worksheets.Add
  10. Set DestSheet = xTWB.ActiveSheet

  11. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
  12. With fldr
  13. .Title = "Select a Folder containing files to merge"
  14. .AllowMultiSelect = False
  15. '.InitialFileName = Application.DefaultFilePath
  16. If .Show <> -1 Then GoTo NextCode
  17. sItem = .SelectedItems(1)
  18. End With
  19. NextCode:

  20. FolderName = sItem
  21. Set fldr = Nothing
  22. FolderPath = FolderName & "\"
  23. FileName = Dir(FolderPath & "*.xls*")
  24. Application.ScreenUpdating = False
  25. Application.Calculation = xlCalculationManual
  26. Application.DisplayAlerts = False
  27. Do While FileName <> ""
  28. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
  29. xStrAWBName = ActiveWorkbook.Name
  30. For Each xWS In ActiveWorkbook.Sheets
  31. If xWS.Name = "Master" Then
  32. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
  33. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
  34. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  35. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  36. If Lr = 1 Then
  37. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
  38. DestSheet.Range("A1").Value = "FileName"
  39. End If
  40. Set Head = xWS.Range("A1")
  41. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
  42. On Error Resume Next
  43. Header = 0
  44. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
  45. On Error GoTo 0
  46. If Header = 0 Then
  47. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
  48. Header = LCD
  49. LCD = LCD + 1
  50. End If
  51. If Lr = 1 Then
  52. Range(DestSheet.Cells(Lr + 2, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  53. Else
  54. Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 2, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  55. End If
  56. Next os
  57. If Lr = 1 Then
  58. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  59. Else
  60. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  61. End If
  62. End If
  63. Next xWS
  64. Workbooks(xStrAWBName).Close
  65. FileName = Dir()
  66. Loop

  67. DestSheet.Activate
  68. DestSheet.Name = "xStrAWBName"
  69. Rows("2:2").Select
  70. Selection.AutoFilter
  71. ActiveWindow.FreezePanes = True
  72. Columns("A:EA").EntireColumn.AutoFit

  73. xTWB.Save
  74. Application.StatusBar = False
  75. Sheets("xStrAWBName").Select
  76. Sheets("xStrAWBName").Move
  77. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False


  78. Application.ScreenUpdating = True
  79. Application.DisplayAlerts = True
  80. Application.Calculation = xlCalculationAutomatic
  81. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
  82. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
  83. End Sub
  84. ==========================================================
I wish it could automatically save the file at LINE 83 as the FolderNAME.CSV.
My issue of the output file being a .CSV has been resolved.
 

chajam

New Member
Joined
Oct 8, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Here is the solution. My headers are on row 1 and 2. Code picks the headers from the first Workbook, Worksheet "Master" then it appends the data from row 3 of every Workbook (Sheets.("Master") until the last Workbook in the folder. Try it out! I have numbered the lines for ease of discussion.

====================================
  1. 'Code courtesy of maabadi, of Mrexcel.com forum
  2. Sub ImportFiles3()
  3. Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
  4. Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
  5. Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
  6. Dim os As Long, LrS As Long, LCS As Long, FileName As String
  7. On Error Resume Next
  8. Set xTWB = ThisWorkbook
  9. Worksheets.Add
  10. Set DestSheet = xTWB.ActiveSheet

  11. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
  12. With fldr
  13. .Title = "Select a Folder containing files to merge"
  14. .AllowMultiSelect = False
  15. '.InitialFileName = Application.DefaultFilePath
  16. If .Show <> -1 Then GoTo NextCode
  17. sItem = .SelectedItems(1)
  18. End With
  19. NextCode:

  20. FolderName = sItem
  21. Set fldr = Nothing
  22. FolderPath = FolderName & "\"
  23. FileName = Dir(FolderPath & "*.xls*")
  24. Application.ScreenUpdating = False
  25. Application.Calculation = xlCalculationManual
  26. Application.DisplayAlerts = False
  27. Do While FileName <> ""
  28. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
  29. xStrAWBName = ActiveWorkbook.Name
  30. For Each xWS In ActiveWorkbook.Sheets
  31. If xWS.Name = "Master" Then
  32. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
  33. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
  34. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  35. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
  36. If Lr = 1 Then
  37. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
  38. DestSheet.Range("A1").Value = "FileName"
  39. End If
  40. Set Head = xWS.Range("A1")
  41. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
  42. On Error Resume Next
  43. Header = 0
  44. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
  45. On Error GoTo 0
  46. If Header = 0 Then
  47. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
  48. Header = LCD
  49. LCD = LCD + 1
  50. End If
  51. If Lr = 1 Then
  52. Range(DestSheet.Cells(Lr + 2, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  53. Else
  54. Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 2, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
  55. End If
  56. Next os
  57. If Lr = 1 Then
  58. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  59. Else
  60. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
  61. End If
  62. End If
  63. Next xWS
  64. Workbooks(xStrAWBName).Close
  65. FileName = Dir()
  66. Loop

  67. DestSheet.Activate
  68. DestSheet.Name = "xStrAWBName"
  69. Rows("2:2").Select
  70. Selection.AutoFilter
  71. ActiveWindow.FreezePanes = True
  72. Columns("A:EA").EntireColumn.AutoFit

  73. xTWB.Save
  74. Application.StatusBar = False
  75. Sheets("xStrAWBName").Select
  76. Sheets("xStrAWBName").Move
  77. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False


  78. Application.ScreenUpdating = True
  79. Application.DisplayAlerts = True
  80. Application.Calculation = xlCalculationAutomatic
  81. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
  82. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
  83. End Sub
  84. ==========================================================
I wish it could automatically save the file at LINE 83 as the FolderNAME.CSV.

When I run this macro, it will save the data in my PERSONAL.XLSB file. How can make it run in the actual master worksheet instead? Which part of the above code has to be changed to the active worksheet?
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,255
Messages
5,836,274
Members
430,414
Latest member
ayla

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top