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
maabadi said:
Sorry my Fault Try This:
VBA Code: 
ActiveWorkbook.SaveAs FileName:=FolderPath & FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
Click to expand...
This is MAGICAL! Tomorrow I give you another challenge with the same code. I think I have disturbed you enough today. Can we try to put a Progress bar tomorrow? Sometimes the files in the folder are so many, I start wondering if the system has crashed or the macro has hanged! I want to restart or make some coffee, then Voila! It was actually working!!! You get the idea? Thank you very much for your very valuable assistance!
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
What about See progress at StatusBar.
First add this macro at the same module of previous code (Before or after it):
VBA Code: 
Function CountFilesInFolder(strDir As String, Optional strType As String) As Long
    Dim file As Variant, i As Integer, T As Integer
    If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
    file = Dir(strDir & strType)
    While (file <> "")
        i = i + 1
        file = Dir
    Wend
    CountFilesInFolder = i
End Function

Then Change Previous code to this:

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
Dim N As Long, T As Long
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 & "\"
T = CountFilesInFolder(FolderPath, "*.xls*")
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
N = N + 1
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()
Application.StatusBar = "Importing Data.. " & N * 100 / T & "% Completed"
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:=FolderPath & FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
Application.StatusBar = 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
 
Upvote 0
maabadi said:
What about See progress at StatusBar.
First add this macro at the same module of previous code (Before or after it):
VBA Code: 
Function CountFilesInFolder(strDir As String, Optional strType As String) As Long
    Dim file As Variant, i As Integer, T As Integer
    If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
    file = Dir(strDir & strType)
    While (file <> "")
        i = i + 1
        file = Dir
    Wend
    CountFilesInFolder = i
End Function

Then Change Previous code to this:

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
Dim N As Long, T As Long
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 & "\"
T = CountFilesInFolder(FolderPath, "*.xls*")
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
N = N + 1
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()
Application.StatusBar = "Importing Data.. " & N * 100 / T & "% Completed"
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:=FolderPath & FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
Application.StatusBar = 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
Click to expand...
I inserted a new Module, then I copied the small code at the beginning, the I put the NEW Sub ImportFiles3(). It runs but freezes with the Status bar saying "Importing Data.. "20% complete".
It would be great to see the Thermometer in the centre of the screen.
 
Upvote 0
KasangoJS said:
I inserted a new Module, then I copied the small code at the beginning, the I put the NEW Sub ImportFiles3(). It runs but freezes with the Status bar saying "Importing Data.. "20% complete".
It would be great to see the Thermometer in the centre of the screen.
Click to expand...
Tested again and again. Its working, but has become slightly slower and the Status bar Progress indicator backlight makes it rather not easy to see. But it is good.
 
Upvote 0
For Progress Bar, Try these actions Step By Step:
1. At Excel window go to Developer Tab, Then Insert
2. At the Activex Control Select First Item (CommandButton)
3. Click on Properties at Developer Tab.
4. Change Caption to Progress Indicator
5. if you want Resize it also &then Close Properties Window.
6. Click on View Code at Developer Tab & Paste this code there:
VBA Code: 
Private Sub CommandButton1_Click()
UserForm1.Show
End Sub
7. Go to VBA Window & Insert Then UserForm
8. At Properties window (Left-Down side) Change Caption to Progress Indicator
9. if you want Resize it also (I wide it to approximate 500px width & 140px Height)
10. Add Label (second option) from ToolBox. and Place it on Top-Center of Userform
11. At Properties window Change Name to Text & BackColor to InactiveBorder & Caption to 0% Completed
12. if you want Change Other Properties:
- I wide it to approximate 230px width & 30px Height)
- I Change Font To TimesNewRoman & Bold It
- I Change Font size to 16 & Textalign to 2-fmTextalignCenter
13. Again From ToolBox Add another Label and Place it on Down-Center of Userform (under of previous Label).
14. At Properties window Change Name to Bar & BackColor to Highlight & Clear Caption. (empty caption)
15. Resize it also (I wide it to approximate 480px width & 18px Height)
16. Now Right-Click on Main Userform and Select View Code.
17. Paste This code:
VBA Code: 
Private Sub UserForm_Activate()
ImportFiles3
End Sub
18. Go to Importfiles3 Code and Change it to this:
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
Dim N As Long, T As Long, N2 As Long
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 & "\"
T = CountFilesInFolder(FolderPath, "*.xls*")
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
N = N + 1
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(0, 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
N2 = (N - 1) * LCS + os + 1
Application.StatusBar = "Importing Data.. " & Round(N2 * 100 / (T * LCS), 2) & "% Completed"
UserForm1.Text.Caption = Round(N2 * 100 / (T * LCS), 2) & "% Completed"
UserForm1.Bar.Width = Round(N2 * 100 / (T * LCS), 2) * 4.8
DoEvents
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
N2 = (N - 1) * LCS + os + 1
Application.StatusBar = "Importing Data.. " & Round(N2 * 100 / (T * LCS), 2) & "% Completed"
UserForm1.Text.Caption = Round(N2 * 100 / (T * LCS), 2) & "% Completed"
UserForm1.Bar.Width = Round(N2 * 100 / (T * LCS), 2) * 4.8
DoEvents
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
[COLOR=rgb(0, 0, 0)]UserForm1.Text.Caption =  "100% Completed"[/COLOR]
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:=FolderPath & FN2 & "MASTERSTACK", FileFormat:=xlCSV, CreateBackup:=False
Application.StatusBar = 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
Also I forgot to Tell
19. Go Back to Excel window & Developer Tab and Inactive Design mode.
20. Now when you Click on Progress indicator Button on sheet your macro run & you can see Progress Bar.
 
Upvote 0
Done all the steps slowly by slowly. Now I have pasted the Importfiles3 code and I see red:-
Progress Bar error.JPG
, I have Teamviewer if you have a momment.
 
Last edited by a moderator:
Upvote 0
I should Clear all [] with text inside from first and last of line & forget. replace it with:
VBA Code: 
Userform1.Text.Caption = "100% Completed"
 
Upvote 0
maabadi said:
I should Clear all [] with text inside from first and last of line & forget. replace it with:
VBA Code: 
Userform1.Text.Caption = "100% Completed"
Click to expand...
Sorry! I just copy pasted as received from you! Kkkkkk
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
MERGE EXCEL FILES
Replies
3
Views
255
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
134
jdhfch
J
M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
423
MountainFog
M
R
  • Question
Merge Excel Multiple Sheets from a single work book to one sheet.
2
Replies
11
Views
320
rtr1811
R
M
  • Solved
Copy the last sheet from file to another with ignore empty whole column
Replies
7
Views
212
mumps
mumps

Forum statistics

Threads
1,216,119
Messages
6,128,947
Members
449,480
Latest member
yesitisasport

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