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.
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
1. How we can define header row titles and from where we can take values?
2. AND how many columns?
 
Upvote 0
maabadi said:
1. How we can define header row titles and from where we can take values?
2. AND how many columns?
Click to expand...
The headers are in row 1 and 2. Columns run up to column EA. Values start at row 3. Last row differs from file to file.
 
Upvote 0
1. You tell headers arrangement is different, then from which file we should take headers?
2. for finding correct headers for match, we use row 1 OR 2?
 
Upvote 0
this macro find header at row 1 and then paste result at headers column after lastrow. for two row headers please upload example image or tell exactly your structure at row 1 & 2. Also define are you have merged cell or No?

VBA Code: 
Sub ImportFiles3()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String, LrS As Long
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, LCS As Long
Dim Head As Range, Header As Long, xArr As Variant, xI As Long, os As Long, R As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    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
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
xArr = Split(xStrName, ",")
For Each xWS In ActiveWorkbook.Sheets
For xI = 0 To UBound(xArr)
If xWS.Name = xArr(xI) 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(1, 2), DestSheet.Cells(1, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(1, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
End If
     Set Head = xWS.Range("A1")
       For os = 0 To xWS.Cells(1, 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
     Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(2, os + 1), xWS.Cells(LrS, os + 1)).Value
       Next os
     Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
End If
Next xI
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
maabadi said:
1. You tell headers arrangement is different, then from which file we should take headers?
2. for finding correct headers for match, we use row 1 OR 2?
Click to expand...
We take headers from row 1 of the first file, all data starts at row3. No merged cells. The sheet I want to merge is called "Master" and it is in every file. There are other sheets in every file but I only want the Master sheet.
 
Upvote 0
Try this:
VBA Code: 
Sub ImportFiles3()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String, LrS As Long
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, LCS As Long
Dim Head As Range, Header As Long, xArr As Variant, xI As Long, os As Long, R As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    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
Set Sh1 = ActiveWorkbook.Sheets("Master")
xStrName = Sh1.Name
xArr = Split(xStrName, ",")
For Each xWS In ActiveWorkbook.Sheets
For xI = 0 To UBound(xArr)
If xWS.Name = xArr(xI) 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(1, 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(1, 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 xI
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
The code is processing but hides the final consolidated file.
If it finds a file that does not have a sheet named "Master" it returns a runtime error.
Maybe I should have control over what files to pick.
Thanks in advance.
 
Upvote 0
KasangoJS said:
The code is processing but hides the final consolidated file.
Click to expand...
I don't understand what you say exactly. but I change code to activate consolidate sheet at active sheet at Last.

For Other Problems Try 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
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    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(1, 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(1, 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 = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Last edited:
Upvote 0
maabadi said:
I don't understand what you say exactly. but I change code to activate consolidate sheet at active sheet at Last.

For Other Problems Try 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
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    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(1, 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(1, 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 = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Click to expand...
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

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

Forum statistics

Threads
1,215,343
Messages
6,124,398
Members
449,155
Latest member
ravioli44

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