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

[sushil84p]

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*****

 

[Alex Blakenburg]

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]

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]

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]

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. 
    
12. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
13. With fldr
14. .Title = "Select a Folder containing files to merge"
15. .AllowMultiSelect = False
16. '.InitialFileName = Application.DefaultFilePath
17. If .Show <> -1 Then GoTo NextCode
18. sItem = .SelectedItems(1)
19. End With
21. NextCode:
22. 
    
23. FolderName = sItem
24. Set fldr = Nothing
25. FolderPath = FolderName & "\"
26. FileName = Dir(FolderPath & "*.xls*")
27. Application.ScreenUpdating = False
28. Application.Calculation = xlCalculationManual
29. Application.DisplayAlerts = False
30. Do While FileName <> ""
31. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
32. xStrAWBName = ActiveWorkbook.Name
33. For Each xWS In ActiveWorkbook.Sheets
34. If xWS.Name = "Master" Then
35. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
36. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
37. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
38. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
39. If Lr = 1 Then
40. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
41. DestSheet.Range("A1").Value = "FileName"
42. End If
43. Set Head = xWS.Range("A1")
44. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
45. On Error Resume Next
46. Header = 0
47. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
48. On Error GoTo 0
50. If Header = 0 Then
51. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
52. Header = LCD
53. LCD = LCD + 1
54. End If
55. If Lr = 1 Then
56. 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
57. Else
58. 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
59. End If
60. Next os
61. If Lr = 1 Then
62. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
63. Else
64. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
65. End If
66. End If
67. Next xWS
68. Workbooks(xStrAWBName).Close
69. FileName = Dir()
70. Loop
71. 
    
72. DestSheet.Activate
73. DestSheet.Name = "xStrAWBName"
74. Rows("2:2").Select
75. Selection.AutoFilter
76. ActiveWindow.FreezePanes = True
77. Columns("A:EA").EntireColumn.AutoFit
78. 
    
79. xTWB.Save
80. Application.StatusBar = False
81. Sheets("xStrAWBName").Select
82. Sheets("xStrAWBName").Move
83. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False
84. 
    
85. 
    
86. Application.ScreenUpdating = True
87. Application.DisplayAlerts = True
88. Application.Calculation = xlCalculationAutomatic
89. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
90. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
91. End Sub
92. ==========================================================

I wish it could automatically save the file at LINE 83 as the FolderNAME.CSV.

 

[jskasango]

You will want to remove Line 80 to 83 because, unlike me, you do not need a CSV file.

 

[jskasango]

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. 
    
12. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
13. With fldr
14. .Title = "Select a Folder containing files to merge"
15. .AllowMultiSelect = False
16. '.InitialFileName = Application.DefaultFilePath
17. If .Show <> -1 Then GoTo NextCode
18. sItem = .SelectedItems(1)
19. End With
21. NextCode:
22. 
    
23. FolderName = sItem
24. Set fldr = Nothing
25. FolderPath = FolderName & "\"
26. FileName = Dir(FolderPath & "*.xls*")
27. Application.ScreenUpdating = False
28. Application.Calculation = xlCalculationManual
29. Application.DisplayAlerts = False
30. Do While FileName <> ""
31. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
32. xStrAWBName = ActiveWorkbook.Name
33. For Each xWS In ActiveWorkbook.Sheets
34. If xWS.Name = "Master" Then
35. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
36. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
37. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
38. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
39. If Lr = 1 Then
40. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
41. DestSheet.Range("A1").Value = "FileName"
42. End If
43. Set Head = xWS.Range("A1")
44. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
45. On Error Resume Next
46. Header = 0
47. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
48. On Error GoTo 0
50. If Header = 0 Then
51. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
52. Header = LCD
53. LCD = LCD + 1
54. End If
55. If Lr = 1 Then
56. 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
57. Else
58. 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
59. End If
60. Next os
61. If Lr = 1 Then
62. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
63. Else
64. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
65. End If
66. End If
67. Next xWS
68. Workbooks(xStrAWBName).Close
69. FileName = Dir()
70. Loop
71. 
    
72. DestSheet.Activate
73. DestSheet.Name = "xStrAWBName"
74. Rows("2:2").Select
75. Selection.AutoFilter
76. ActiveWindow.FreezePanes = True
77. Columns("A:EA").EntireColumn.AutoFit
78. 
    
79. xTWB.Save
80. Application.StatusBar = False
81. Sheets("xStrAWBName").Select
82. Sheets("xStrAWBName").Move
83. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False
84. 
    
85. 
    
86. Application.ScreenUpdating = True
87. Application.DisplayAlerts = True
88. Application.Calculation = xlCalculationAutomatic
89. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
90. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
91. End Sub
92. ==========================================================

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.

 

[Fluff]

@KasangoJS in future when posting code, please use code tags. Do not turn your code into a list. How to Post Your VBA Code

 

[jskasango]

@KasangoJS in future when posting code, please use code tags. Do not turn your code into a list. How to Post Your VBA Code

Noted with thanks. I had already sent two the bad way. I apologize.

 

[chajam]

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. 
    
12. Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
13. With fldr
14. .Title = "Select a Folder containing files to merge"
15. .AllowMultiSelect = False
16. '.InitialFileName = Application.DefaultFilePath
17. If .Show <> -1 Then GoTo NextCode
18. sItem = .SelectedItems(1)
19. End With
21. NextCode:
22. 
    
23. FolderName = sItem
24. Set fldr = Nothing
25. FolderPath = FolderName & "\"
26. FileName = Dir(FolderPath & "*.xls*")
27. Application.ScreenUpdating = False
28. Application.Calculation = xlCalculationManual
29. Application.DisplayAlerts = False
30. Do While FileName <> ""
31. Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
32. xStrAWBName = ActiveWorkbook.Name
33. For Each xWS In ActiveWorkbook.Sheets
34. If xWS.Name = "Master" Then
35. Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
36. LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
37. LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
38. LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
39. If Lr = 1 Then
40. Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
41. DestSheet.Range("A1").Value = "FileName"
42. End If
43. Set Head = xWS.Range("A1")
44. For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
45. On Error Resume Next
46. Header = 0
47. Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
48. On Error GoTo 0
50. If Header = 0 Then
51. DestSheet.Cells(1, LCD) = Head.Offset(0, os)
52. Header = LCD
53. LCD = LCD + 1
54. End If
55. If Lr = 1 Then
56. 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
57. Else
58. 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
59. End If
60. Next os
61. If Lr = 1 Then
62. Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
63. Else
64. Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
65. End If
66. End If
67. Next xWS
68. Workbooks(xStrAWBName).Close
69. FileName = Dir()
70. Loop
71. 
    
72. DestSheet.Activate
73. DestSheet.Name = "xStrAWBName"
74. Rows("2:2").Select
75. Selection.AutoFilter
76. ActiveWindow.FreezePanes = True
77. Columns("A:EA").EntireColumn.AutoFit
78. 
    
79. xTWB.Save
80. Application.StatusBar = False
81. Sheets("xStrAWBName").Select
82. Sheets("xStrAWBName").Move
83. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False
84. 
    
85. 
    
86. Application.ScreenUpdating = True
87. Application.DisplayAlerts = True
88. Application.Calculation = xlCalculationAutomatic
89. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
90. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
91. End Sub
92. ==========================================================

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?