VBA Merge specific sheets from files in a folder

jskasango

jskasango

Board Regular
Joined
Jul 18, 2012
Messages
202
Office Version
  1. 365
Platform
  1. Windows
VBA Merge specific sheets from files in a folder. I want my sheets to be merged into ONE sheet after matching the column headers. If its ok with you, column A can contain the source file name. Thanks in advance.
 
Sort by date Sort by votes
What means second time running. It only need one time running to add all files at selected folder to active sheet?
What means active area?
Also you don't answer exactly how we take header? Then I take all headers from first files and then each one doesn't exist at first file add after last column.
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Thank you very much [B]maabadi[/B] for the code. I need to merge data from various years and in many different series. Meaning I will run the code multiple times to make the merged data sets stored in many different folders. I have just realized that my excel is misbehaving, so once it stabilizes, then I will use the code.
 
Upvote 0
You're Welcome & Thanks for feedback. For second time running & others data added after last row of data based column headers. If one if headers doesn't exist add after last column also.
 
Upvote 0
KasangoJS said:
It worked on first run! When I run it a second time it only picks the headers and places the source filename in column A, the data in the active area is ignored! But the first run, it worked fine.
Click to expand...
After a few tweaks here and there, I am happy, very happy with your solution. It now looks like this:-
Please look at line 82 and help me make it save the CSV by picking the current fodername like this (FoldernameMASTERSTACK.CSV).
I have put in bold the parts that I changed.
==========================================================================
  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

  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:

  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

  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

  79. xTWB.Save
  80. Sheets("xStrAWBName").Select
  81. Sheets("xStrAWBName").Move
  82. ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False
  83. Application.ScreenUpdating = True
  84. Application.DisplayAlerts = True
  85. Application.Calculation = xlCalculationAutomatic
  86. MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
  87. & "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
  88. End Sub
 
Upvote 0
I changed code to this but don't test it?

I add these
1. TO Dim Part
, DD As Long, FN2 As String
2. After Foldername
DD = InStrRev(FolderName, "\")
FN2 = Right(FolderName, Len(FolderName) - DD)
3. AND change Filename at Lin82
VBA Code: 
Sub ImportFiles3()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String, DD As Long, FN2 As String
On Error Resume Next
Set xTWB = ThisWorkbook
Worksheets.Add
Set DestSheet = xTWB.ActiveSheet


Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder containing files to merge"
.AllowMultiSelect = False
'.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With


NextCode:


FolderName = sItem
DD = InStrRev(FolderName, "\")
FN2 = Right(FolderName, Len(FolderName) - DD)
Set fldr = Nothing
FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "Master" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(DestSheet.Cells([B]0[/B], 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
End If
Set Head = xWS.Range("A1")
For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
On Error Resume Next
Header = 0
Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
On Error GoTo 0


If Header = 0 Then
DestSheet.Cells(1, LCD) = Head.Offset(0, os)
Header = LCD
LCD = LCD + 1
End If
If Lr = 1 Then
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
Else
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
End If
Next os
If Lr = 1 Then
Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
Else
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop


DestSheet.Activate
DestSheet.Name = "xStrAWBName"
Rows("2:2").Select
Selection.AutoFilter
ActiveWindow.FreezePanes = True
Columns("A:EA").EntireColumn.AutoFit


xTWB.Save
Sheets("xStrAWBName").Select
Sheets("xStrAWBName").Move
ActiveWorkbook.SaveAs FileName:=[U]FN2 & "[/U][B][U]MASTERSTACK"[/U][/B], FileFormat:=xlCSV, CreateBackup:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "MASTERS MERGED for " & xStrAWBName & vbLf & vbLf _
& "YOU CAN NOW FILTER AND KNOCK OUT SETS WITH NO PLANTING DATES!", vbInformation
End Sub
 
Last edited:
Upvote 0
AND I forgot to clear bold & underline from Saveas Line change it to this:

VBA Code: 
ActiveWorkbook.SaveAs FileName:=FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
 
Upvote 0
One other thing. I see @sushil84p Post. It doesn't need CSV file. you can Post my first code at Post #5 I sent at this Thread with one row header and only extract sheet1.
 
Last edited:
Upvote 0
maabadi said:
AND I forgot to clear bold & underline from Saveas Line change it to this:

VBA Code: 
ActiveWorkbook.SaveAs FileName:=FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
Click to expand...
Working like MAGIC! Except that it is saving the CSV file outside the folder. It should save the CSV file in the same folder where the workbooks were fished from. WOW!
 
Upvote 0
If you want full Path then you don't need FN2 variable use FolderName
VBA Code: 
ActiveWorkbook.SaveAs FileName:=FolderName & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
 
Upvote 0
Sorry my Fault Try This:
VBA Code: 
ActiveWorkbook.SaveAs FileName:=FolderPath & FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
MERGE EXCEL FILES
Replies
3
Views
251
ExcelToDAX
E
J
  • Question
VBA to clear all date in columns A2 to AC in the destination file, then copy the data from the same columns from all files in a folder
Replies
1
Views
131
jdhfch
J
M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
406
MountainFog
M
R
  • Question
Merge Excel Multiple Sheets from a single work book to one sheet.
2
Replies
11
Views
300
rtr1811
R
M
  • Solved
Copy the last sheet from file to another with ignore empty whole column
Replies
7
Views
207
mumps
mumps

Forum statistics

Threads
1,216,041
Messages
6,128,467
Members
449,455
Latest member
jesski

Share this page

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
Back
Top