Macro to consolidate various files + select sheet

L

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
 
Sort by date Sort by votes
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
mumps said:
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
Click to expand...

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
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
mumps said:
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
Click to expand...

Works!:D
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
1K
GarnesGambit
G
Y
  • Question Question
Modify Macro to Select 1 .TXT File at a time, do changes on it (tab delimeter+column to text) to convert to .XLS file+save the file then select other
Replies
0
Views
577
yferrer
Y
H
  • Question Question
Macro to Open File and limit selection where files contains "Parts" in C
Replies
4
Views
345
howard
H
R
  • Solved
combining csv workbooks to single sheet - vba works but need help adjusting
Replies
4
Views
672
Alex Blakenburg
A
E
  • Solved
Force Excel 2019 VBA to import multiple txt file to existing sheet & not seperate wk.book / wk.sheets
Replies
1
Views
737
Domenic
D

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