Merge different Excel worksheet from different workbooks into one workbook

[rimcus]

Hello everyone,

I want to create a database of my old clients from the quotes I've made in the past. To do so I thought about merging all the workbooks in one (Every quote has 3 worksheets, only one is filled), then filling the database with the key informations thanks to the INDIRECT command.

The Problem is that I have many files and cant merge them manually, and I'm using a mac so can't do it with power query, I tried many VBA codes I found online with no results. All the workbooks are in the same file. Here's an example of a code I found in this forum :

Public Sub ConslidateWorkbooks()Dim this As Workbook
Dim Sheet As Worksheet
Dim Nextcell As Range
Dim FolderPath As String
Dim Filename As String
Dim Lastrow As Long

    Application.ScreenUpdating = False
    
    FolderPath = Environ("userprofile") & "\Documents\Reports\"
    Filename = Dir(FolderPath & "*.xls*")
    Do While Filename <> ""
    
        Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
        
        For Each Sheet In ActiveWorkbook.Sheets
        
            Call SheetExists(Sheet.Name, ThisWorkbook, True)
            Lastrow = ThisWorkbook.Worksheets(Sheet.Name).Range("A1").SpecialCells(xlCellTypeLastCell).Row
            If Lastrow = 1 And ThisWorkbook.Worksheets(Sheet.Name).Range("A1").Value = vbNullString Then Lastrow = 0
            
            Sheet.UsedRange.Copy ThisWorkbook.Worksheets(Sheet.Name).Cells(Lastrow + 1, "A")
        Next Sheet
        
        Workbooks(Filename).Close
        Filename = Dir()
    Loop
    
    Application.ScreenUpdating = True
End Sub

Public Function SheetExists( _
    ByVal Name As String, _
    Optional ByRef Wb As Workbook, _
    Optional ByVal Create As Boolean = False) As Boolean
Dim res As Boolean

    If Wb Is Nothing Then Set Wb = ActiveWorkbook
    On Error Resume Next
    res = CBool(Not Wb.Worksheets(Name) Is Nothing)
    If Not res And Create Then
    
        Wb.Worksheets.Add After:=Wb.Worksheets(Wb.Worksheets.Count)
        Wb.Worksheets(Wb.Worksheets.Count).Name = Name
    End If
    SheetExists = res End Function

Thank you for reading me

 

[maabadi]

Welcome to MrExcel Message Board.
What is the First cell is filled at Sheets. For Example A2 at all workbooks to use at Criteria

 

[Fluff]

As you are on a mac, have a look here Merge Excel Workbooks | Mac Excel Automation

 

[Ron de Bruin]

Or try

RDBMerge | Mac Excel Automation

Merge Add-in for Excel 2016 or higher for the Mac

www.macexcel.com

 

[maabadi]

With suppose column A And Row 1 filled at source sheets try this:

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  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 & "\"
   
Set wbNew = Workbooks.Add
Set xTWB = ThisWorkbook
Set Sh1 = xTWB.Sheets("Sheet1")
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
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200"))
If R > 0 Then
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row
LC = xWS.Cells(1, Columns.Count).End(xlToLeft).Column
Lr2 = xTWB.Sh1.Range("A" & Rows.Count).End(xlUp).Row
xWS.Range(Cells(1, 1), Cells(Lr1, LC)).Copy xTWB.Sh1.Range("A" & Lr2 + 1)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[rimcus]

Or try

RDBMerge | Mac Excel Automation

Merge Add-in for Excel 2016 or higher for the Mac

www.macexcel.com

Hi ron,

Thank you for the answer, i tried your add-on, it works well but it combine the different sheets into one, which make it impossible for me to pick up the informations in need to build my database.
Here's a "mini-****" with the formulas I thought about to get the job done. If you have any other recommendations, I'm all ears

Synthese 2017.xlsx
	B
10
Combine

 

[rimcus]

Something went wrong, here's what I wanted to post :

Synthese 2017.xlsx
	A	B	C	D	E	F	G	H
1	NAME	ADDRESS	ZIP CODE	CITY	CONTACT	TYPE OF WORK		help number
2	Leader Price	Boulevard Pont de Peton	13120	Gardanne	Téléphone client :	Travaux : Recherche de fuites		1
3	Mme Lahouel	5 bd de la lousiane	13014	Marseille	Téléphone client : 0617744734	Travaux : Zinguerie		2
4	Mme Pouillon	83 Chemin de beaurecueil	13100	Aix-en-Provence	Téléphone client : 0664900012	Travaux : Refection de Toiture		3
5	Mme Riquebourg	95 Avenue Jean Monnet	131090	Aix-En-Provence	Téléphone client : 0676602359	Travaux : Pose de Vélux		4
6	Mme Rocchia	2789 Chemin de Saint Donat	13100	Aix-En-Provence	Téléphone client : 0675227752	Travaux : Construction Annexe		5
7	Marseille Construction	136 Rue François Mauriac	13010	Marseille	Téléphone client : 0621058371	Travaux : Réparation de Toiture		6
8	Mme Rocchia	2789 Chemin de Saint Donat	13100	Aix-En-Provence	Téléphone client : 0675227752	Travaux : Construction Annexe		7
9	Mme Jacoby	30 Rue Borely	13120	Gardanne	Téléphone client : 0667788924	Travaux : Révision de Toiture		8
Combine

Cell Formulas
Range	Formula
A2:A9	A2	=INDIRECT("'Sheet" & H2 & "'!$G$11")
B2:B9	B2	=INDIRECT("'Sheet" & H2 & "'!$G$12")
C2:C9	C2	=INDIRECT("'Sheet" & H2 & "'!$G$13")
D2:D9	D2	=INDIRECT("'Sheet" & H2 & "'!$G$14")
E2:E9	E2	=INDIRECT("'Sheet" & H2 & "'!$B$22")
F2:F9	F2	=INDIRECT("'Sheet" & H2 & "'!$B$17")

 

[rimcus]

With suppose column A And Row 1 filled at source sheets try this:

Sub ImportFiles()
Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
  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 & "\"
  
Set wbNew = Workbooks.Add
Set xTWB = ThisWorkbook
Set Sh1 = xTWB.Sheets("Sheet1")
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
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200"))
If R > 0 Then
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row
LC = xWS.Cells(1, Columns.Count).End(xlToLeft).Column
Lr2 = xTWB.Sh1.Range("A" & Rows.Count).End(xlUp).Row
xWS.Range(Cells(1, 1), Cells(Lr1, LC)).Copy xTWB.Sh1.Range("A" & Lr2 + 1)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Hi maabadi,

Thanks for your answers, I tried your code, it did create a new workbook named combine, but it was completely empty, should I have personalized the code somehow ?

Regards

 

[maabadi]

I think it is because you're work on MacOS.

 

[rimcus]

I think it is because you're work on MacOS.

I will try on my old windows laptop tomorrow, keep you in touch.