Macro to copy same cells form all files in a folder

H

henrybrent1974

New Member
Joined
Oct 11, 2017
Messages
19
Need macro to copy these specific cells to new file.
Every file in the folder has same sheets.

Sheet name: "16 Man Bracket"
Cells that need to be copied from "16 Man Bracket" are: AX20 thru AX25

Sheet name: "32 Man Bracket"
Cells that need to be copied from "32 Man Bracket" are: BJ26 thru BJ31

Copy to new file.
Sheet Name: "Summary"

Thanks in advance for any help!
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Where on the Summary sheet do you want to paste the copied ranges? What is the full path to the folder containing your source files? Are the source files the only files in that folder?
 
Upvote 0
The following allows you to select the source files and will copy and paste the data into a new workbook named Summary.xls starting in cell A2.

Let me know if you have any issues.

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                
                'Loops through each range
                For j = 1 To 2
                
                    'Determines which sheet to paste in
                    If j = 1 Then
                        shtName = "16 Man Bracket" 
                    Else
                        shtName = "32 Man Bracket" 
                    End If
                    
                    'Finds last row of variable sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                    'Determines which row to paste in
                    If j = 1 Then
                        'Sets range according to variable sheet
                        Set rng = Sheets(shtName).Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)
                    Else
                        'Sets range according to variable sheet
                        Set rng = Sheets(shtName).Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)
                    End If
                    
                Next j
            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Last edited:
Upvote 0
Without some unneeded parts:

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select 5 source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through 5 source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("16 Man Bracket").Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("32 Man Bracket").Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Last edited:
Upvote 0
mumps said:
Where on the Summary sheet do you want to paste the copied ranges? What is the full path to the folder containing your source files? Are the source files the only files in that folder?
Click to expand...

1. Start on cell A1
2. C:\Users\Brent.WSN\Downloads\Dukes Tournament of Champions\Weekly
3. Yes
 
Upvote 0
D3allamerican07 said:
Without some unneeded parts:

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select 5 source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through 5 source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("16 Man Bracket").Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("32 Man Bracket").Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
Click to expand...

Not working. I think because all my files are .xlsm files.
 
Upvote 0
Changed the selection portion to accept .xlsm

Try it now.

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select 5 source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsm), *.xlsm", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through 5 source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("16 Man Bracket").Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("32 Man Bracket").Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Upvote 0
D3allamerican07 said:
Changed the selection portion to accept .xlsm

Try it now.

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select 5 source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsm), *.xlsm", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through 5 source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("16 Man Bracket").Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

                    'Finds last row of Summary sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("32 Man Bracket").Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1)

            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
Click to expand...

It runs through the code and says task complete but all it has is #REF ! in all the cells
 
Upvote 0
Do you want to copy the range vertically or horizontally starting in A1?
 
Upvote 0
Are there formulas in the ranges you want to copy?

Try:

Code: 
Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="Summary" & ".xls"
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Header"
    
    'Prompts user to select source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsm), *.xlsm", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                

                    'Finds last row of variable sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("16 Man Bracket").Range("AX20:AX25")
                        
                        'Copies range from source file to Summary workbook
                        rng.Copy
                        Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1).PasteSpecial xlPasteValues

                    'Finds last row of variable sheet
                    LR = Workbooks("Summary.xls").Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                    
                        'Sets range according to variable sheet
                        Set rng = Sheets("32 Man Bracket").Range("BJ26:BJ31")
                        
                        'Copies range from source file to Summary sheet
                        rng.Copy
                        Workbooks("Summary.xls").Sheets("Summary").Range("A" & LR + 1).PasteSpecial xlPasteValues

            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
859
Micron
M
S
  • Question Question
How to shorten file name which is used to name the sheet name in a master file using VBA?
Replies
4
Views
67
mumps
mumps
Y
  • Question Question
Consolidate all values from specific sheets into 1 master excel file
Replies
1
Views
181
Trebor76
T
A
  • Question Question
Macro to import the same sheets names are repeated across files.
Replies
0
Views
57
Amer Omar
A
R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
197
Ramadan2512
R

Forum statistics

Threads
1,223,911
Messages
6,175,326
Members
452,635
Latest member
laura12345

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