Macro to consolidate various files + select sheet

lucius1707

New Member
Joined
Dec 23, 2016
Messages
3
I'm using the macro below to try to consolidate 4000+ files, but i need to be able to consolidate reports that are divided by the same sheet name in each file (around 8).
What do i need to change so i can input the sheet name that i want and then excel consolidate just the reports from this specific sheet in the big file?

Thank you guys very much!
Merry Christmas :)

Code:
Option Explicit


Sub ConsolidateAll()
 
    Dim wkbConsol As Workbook
    Dim wksConsol As Worksheet
    Dim wkbOpen As Workbook
    Dim wksOpen As Worksheet
    Dim FolderName As String
    Dim FileName As String
    Dim Cnt As Long
    
    Application.ScreenUpdating = False
     
    Application.StatusBar = "Please wait..."
     
    Set wkbConsol = ActiveWorkbook
    Set wksConsol = wkbConsol.Worksheets(1)
    
    'Change the path accordingly
    FolderName = "C:\Users\212465810\Box Sync\Fiscalização TP - 2013\PRL"
     
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
    
    FileName = Dir(FolderName & "*.xls")
    
    Cnt = 1
    Do While FileName <> ""
        If FileName <> wkbConsol.Name Then
            Application.StatusBar = "Opening " & FileName & "..."
            Set wkbOpen = Workbooks.Open(FolderName & FileName)
            Set wksOpen = wkbOpen.Worksheets(2)
            Application.StatusBar = "Copying the data from " & FileName & "..."
            With wksOpen.UsedRange
                If Cnt = 1 Then
                    .Copy
                    wksConsol.Cells(1, "A").PasteSpecial Paste:=xlPasteValues
                Else
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy
                    wksConsol.Cells(wksConsol.Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
            End With
            wkbOpen.Close savechanges:=False
            Application.StatusBar = FileName & " closed..."
        End If
        FileName = Dir
        Cnt = Cnt + 1
    Loop
     
    Application.StatusBar = False
    
    Application.ScreenUpdating = True
 
End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
12,724
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
Try:
Code:
Option Explicit
Sub ConsolidateAll()
    Dim wkbConsol As Workbook
    Dim wksConsol As Worksheet
    Dim wkbOpen As Workbook
    Dim wksOpen As Worksheet
    Dim response As String
    Dim FolderName As String
    Dim FileName As String
    Dim Cnt As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Please wait..."
    Set wkbConsol = ActiveWorkbook
    Set wksConsol = wkbConsol.Worksheets(1)
    'Change the path accordingly
    FolderName = "C:\Users\212465810\Box Sync\Fiscalização TP - 2013\PRL"
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
    FileName = Dir(FolderName & "*.xls")
    Cnt = 1
    Do While FileName <> ""
        If FileName <> wkbConsol.Name Then
            Application.StatusBar = "Opening " & FileName & "..."
            response = InputBox("Please enter the sheet name.")
            Set wkbOpen = Workbooks.Open(FolderName & FileName)
            Set wksOpen = wkbOpen.Sheets(response)
            Application.StatusBar = "Copying the data from " & FileName & "..."
            With wksOpen.UsedRange
                If Cnt = 1 Then
                    .Copy
                    wksConsol.Cells(1, "A").PasteSpecial Paste:=xlPasteValues
                Else
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy
                    wksConsol.Cells(wksConsol.Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
            End With
            wkbOpen.Close savechanges:=False
            Application.StatusBar = FileName & " closed..."
        End If
        FileName = Dir
        Cnt = Cnt + 1
    Loop
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0

lucius1707

New Member
Joined
Dec 23, 2016
Messages
3
Try:
Code:
Option Explicit
Sub ConsolidateAll()
    Dim wkbConsol As Workbook
    Dim wksConsol As Worksheet
    Dim wkbOpen As Workbook
    Dim wksOpen As Worksheet
    Dim response As String
    Dim FolderName As String
    Dim FileName As String
    Dim Cnt As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Please wait..."
    Set wkbConsol = ActiveWorkbook
    Set wksConsol = wkbConsol.Worksheets(1)
    'Change the path accordingly
    FolderName = "C:\Users\212465810\Box Sync\Fiscalização TP - 2013\PRL"
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
    FileName = Dir(FolderName & "*.xls")
    Cnt = 1
    Do While FileName <> ""
        If FileName <> wkbConsol.Name Then
            Application.StatusBar = "Opening " & FileName & "..."
            response = InputBox("Please enter the sheet name.")
            Set wkbOpen = Workbooks.Open(FolderName & FileName)
            Set wksOpen = wkbOpen.Sheets(response)
            Application.StatusBar = "Copying the data from " & FileName & "..."
            With wksOpen.UsedRange
                If Cnt = 1 Then
                    .Copy
                    wksConsol.Cells(1, "A").PasteSpecial Paste:=xlPasteValues
                Else
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy
                    wksConsol.Cells(wksConsol.Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
            End With
            wkbOpen.Close savechanges:=False
            Application.StatusBar = FileName & " closed..."
        End If
        FileName = Dir
        Cnt = Cnt + 1
    Loop
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

It works but it asks me to type the sheet name everytime it opens a new file (So i have to type it 4000+ times), i will try to adjust the code, thanks :)
 
Upvote 0

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
12,724
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
Try:
Code:
Option Explicit
Sub ConsolidateAll()
    Dim wkbConsol As Workbook
    Dim wksConsol As Worksheet
    Dim wkbOpen As Workbook
    Dim wksOpen As Worksheet
    Dim response As String
    Dim FolderName As String
    Dim FileName As String
    Dim Cnt As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Please wait..."
    Set wkbConsol = ActiveWorkbook
    Set wksConsol = wkbConsol.Worksheets(1)
    'Change the path accordingly
    FolderName = "C:\Users\212465810\Box Sync\Fiscalização TP - 2013\PRL"
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
    FileName = Dir(FolderName & "*.xls")
    Cnt = 1
    response = InputBox("Please enter the sheet name.")
    Do While FileName <> ""
        If FileName <> wkbConsol.Name Then
            Application.StatusBar = "Opening " & FileName & "..."
            Set wkbOpen = Workbooks.Open(FolderName & FileName)
            Set wksOpen = wkbOpen.Sheets(response)
            Application.StatusBar = "Copying the data from " & FileName & "..."
            With wksOpen.UsedRange
                If Cnt = 1 Then
                    .Copy
                    wksConsol.Cells(1, "A").PasteSpecial Paste:=xlPasteValues
                Else
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy
                    wksConsol.Cells(wksConsol.Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
            End With
            wkbOpen.Close savechanges:=False
            Application.StatusBar = FileName & " closed..."
        End If
        FileName = Dir
        Cnt = Cnt + 1
    Loop
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

lucius1707

New Member
Joined
Dec 23, 2016
Messages
3
Try:
Code:
Option Explicit
Sub ConsolidateAll()
    Dim wkbConsol As Workbook
    Dim wksConsol As Worksheet
    Dim wkbOpen As Workbook
    Dim wksOpen As Worksheet
    Dim response As String
    Dim FolderName As String
    Dim FileName As String
    Dim Cnt As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Please wait..."
    Set wkbConsol = ActiveWorkbook
    Set wksConsol = wkbConsol.Worksheets(1)
    'Change the path accordingly
    FolderName = "C:\Users\212465810\Box Sync\Fiscalização TP - 2013\PRL"
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
    FileName = Dir(FolderName & "*.xls")
    Cnt = 1
    response = InputBox("Please enter the sheet name.")
    Do While FileName <> ""
        If FileName <> wkbConsol.Name Then
            Application.StatusBar = "Opening " & FileName & "..."
            Set wkbOpen = Workbooks.Open(FolderName & FileName)
            Set wksOpen = wkbOpen.Sheets(response)
            Application.StatusBar = "Copying the data from " & FileName & "..."
            With wksOpen.UsedRange
                If Cnt = 1 Then
                    .Copy
                    wksConsol.Cells(1, "A").PasteSpecial Paste:=xlPasteValues
                Else
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy
                    wksConsol.Cells(wksConsol.Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
            End With
            wkbOpen.Close savechanges:=False
            Application.StatusBar = FileName & " closed..."
        End If
        FileName = Dir
        Cnt = Cnt + 1
    Loop
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Works!:D
 
Upvote 0

Forum statistics

Threads
1,191,383
Messages
5,986,304
Members
440,017
Latest member
vasanrajeswaran

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