VBA to Merge Workbooks in a folder by checking workbook names

[Smerdis13]

Hi Guys,
i have one folder where there are some workbooks with names as below:
Workbook1 = A-Audi
Workbook2 = B-Audi
Workbook3 = A-BMW
Workbook4 = B-BMW
.....
for every workbook after "-", there are 2 files with same names (as the sample) and files with same name after "-" have same columns
result would be one new work book with sheets as:
Sheet1 = Audi
Sheet2 = BMW
.....
Thanks in advance for great support

 

[eiloken]

You need macro that will find same name after "-" of each file and merge its data into worksheet with name after "-" right? but what data in these files? i need data form to know how it merged

 

[Smerdis13]

You need macro that will find same name after "-" of each file and merge its data into worksheet with name after "-" right? but what data in these files? i need data form to know how it merged

Yes Dear, Exactly. each file with same name afte "-" have same structure and column name with different row numbers
data includes both number and texts
please let me know how can i upload 6 workbooks as sample here
i will upload and share link here
VBA to Merge Workbooks in a folder by checking workbook names.rar - Icedrive

 

[eiloken]

Yes Dear, Exactly. each file with same name afte "-" have same structure and column name with different row numbers
data includes both number and texts
please let me know how can i upload 6 workbooks as sample here
i will upload and share link here
VBA to Merge Workbooks in a folder by checking workbook names.rar - Icedrive

with this macro you need choose folder include your files, it will merge all file with same name after "-" into one sheet (with auto create sheet with same name as file input):

Sub MergeFiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object, fol As Object, fil As Object
    Dim lr As Integer
    Dim wbi As Workbook, wsi As Worksheet, wso As Worksheet
    Dim filname As String, shName As String, filext As String, filPath As String
    Set folder = Application.FileDialog(msoFileDialogFolderPicker) 'Choose parent folder
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(xDir)
    For Each fil In fol.Files 'loop through files in folder
        filext = fso.GetExtensioNname(fil)
        If filext Like "xls*" Then 'check that file is excel file
            filname = fso.GetBaseName(fil)
            If filname Like "*-*" Then 'check file name include '-'
                shName = Trim(Right(filname, Len(filname) - InStr(filname, "-"))) 'split name after '-'
                filPath = fso.GetAbsolutePathName(fil) 'file path
                Set wbi = Workbooks.Open(fso.GetAbsolutePathName(filPath)) ' open file
                Set wsi = wbi.Sheets(1)
                If FindSheet(shName) Is Nothing Then 'check that sheet has same name as file exist or not
                    Set wso = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)) 'if sheet not exist then create new sheet
                    wso.Name = shName 'rename sheet
                Else
                    Set wso = FindSheet(shName) 'if sheet existed
                End If
                lr = wso.UsedRange.Rows.count
                wsi.UsedRange.Copy Destination:=wso.Cells(lr + 1, 1) 'get data and paste to sheet
                wbi.Close (False)
            End If
        End If
    Next fil
    Set fil = Nothing
    Set fol = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function FindSheet(ByVal shName As String) As Worksheet 'find match worksheet
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = shName Then
            Set FindSheet = ws
            Exit For
        End If
    Next ws
End Function

 

[Smerdis13]

with this macro you need choose folder include your files, it will merge all file with same name after "-" into one sheet (with auto create sheet with same name as file input):

Sub MergeFiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object, fol As Object, fil As Object
    Dim lr As Integer
    Dim wbi As Workbook, wsi As Worksheet, wso As Worksheet
    Dim filname As String, shName As String, filext As String, filPath As String
    Set folder = Application.FileDialog(msoFileDialogFolderPicker) 'Choose parent folder
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(xDir)
    For Each fil In fol.Files 'loop through files in folder
        filext = fso.GetExtensioNname(fil)
        If filext Like "xls*" Then 'check that file is excel file
            filname = fso.GetBaseName(fil)
            If filname Like "*-*" Then 'check file name include '-'
                shName = Trim(Right(filname, Len(filname) - InStr(filname, "-"))) 'split name after '-'
                filPath = fso.GetAbsolutePathName(fil) 'file path
                Set wbi = Workbooks.Open(fso.GetAbsolutePathName(filPath)) ' open file
                Set wsi = wbi.Sheets(1)
                If FindSheet(shName) Is Nothing Then 'check that sheet has same name as file exist or not
                    Set wso = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)) 'if sheet not exist then create new sheet
                    wso.Name = shName 'rename sheet
                Else
                    Set wso = FindSheet(shName) 'if sheet existed
                End If
                lr = wso.UsedRange.Rows.count
                wsi.UsedRange.Copy Destination:=wso.Cells(lr + 1, 1) 'get data and paste to sheet
                wbi.Close (False)
            End If
        End If
    Next fil
    Set fil = Nothing
    Set fol = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function FindSheet(ByVal shName As String) As Worksheet 'find match worksheet
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = shName Then
            Set FindSheet = ws
            Exit For
        End If
    Next ws
End Function

Thanks Dear a lot. it works perfectly fine, just one thing
it seems after new sheet created one blank row is added in first of each sheet, is it possible to remove this and same headers be the first row? thanks in advance

 

[eiloken]

Thanks Dear a lot. it works perfectly fine, just one thing
it seems after new sheet created one blank row is added in first of each sheet, is it possible to remove this and same headers be the first row? thanks in advance

look like your table has 2 first row as header so you can try this:

Sub MergeFiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object, fol As Object, fil As Object
    Dim lr As Long
    Dim wbi As Workbook, wsi As Worksheet, wso As Worksheet
    Dim filname As String, shName As String, filext As String, filPath As String
    Set folder = Application.FileDialog(msoFileDialogFolderPicker) 'Choose parent folder
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(xDir)
    For Each fil In fol.Files 'loop through files in folder
        filext = fso.GetExtensioNname(fil)
        If filext Like "xls*" Then 'check that file is excel file
            filname = fso.GetBaseName(fil)
            If filname Like "*-*" Then 'check file name include '-'
                shName = Trim(Right(filname, Len(filname) - InStr(filname, "-"))) 'split name after '-'
                filPath = fso.GetAbsolutePathName(fil) 'file path
                Set wbi = Workbooks.Open(fso.GetAbsolutePathName(filPath)) ' open file
                Set wsi = wbi.Sheets(1)
                If FindSheet(shName) Is Nothing Then 'check that sheet has same name as file exist or not
                    Set wso = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)) 'if sheet not exist then create new sheet
                    wso.Name = shName 'rename sheet
                Else
                    Set wso = FindSheet(shName) 'if sheet existed
                End If
                If wso.UsedRange.Rows.count = 1 Then
                    lr = 1
                    wsi.UsedRange.Copy Destination:=wso.Cells(lr, 1) 'get data and paste to sheet
                Else
                    lr = wso.UsedRange.Rows.count + 1
                    Intersect(wsi.UsedRange, wsi.UsedRange.Offset(2)).Copy Destination:=wso.Cells(lr, 1) 'get data and paste to sheet
                End If
                wbi.Close (False)
            End If
        End If
    Next fil
    Set fil = Nothing
    Set fol = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function FindSheet(ByVal shName As String) As Worksheet 'find match worksheet
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = shName Then
            Set FindSheet = ws
            Exit For
        End If
    Next ws
End Function