Merge different Excel worksheet from different workbooks into one workbook

rimcus

New Member
Joined
Jan 29, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. MacOS
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 :

VBA Code:
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
 

Some videos you may like

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Welcome to MrExcel Message Board.
What is the First cell is filled at Sheets. For Example A2 at all workbooks to use at Criteria
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

With suppose column A And Row 1 filled at source sheets try this:
VBA Code:
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

New Member
Joined
Jan 29, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. MacOS
Or try

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

New Member
Joined
Jan 29, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. MacOS
With suppose column A And Row 1 filled at source sheets try this:
VBA Code:
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

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I think it is because you're work on MacOS.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,404
Messages
5,624,557
Members
416,034
Latest member
Shiv kumar

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
Top