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

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
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

D
  • Question
VBA - Open Files then copy specific cells into a new row.
Replies
1
Views
229
dhubz
D
M
  • Solved
Copy the last sheet from file to another with ignore empty whole column
Replies
7
Views
171
mumps
mumps
B
  • Solved
VBA copy and paste as values and save as new file based on table list
Replies
4
Views
96
Peter_SSs
Peter_SSs
H
  • Solved
How to copy data from one file and paste it into a dynamically named workbook
Replies
3
Views
193
dermie_72
D
GMC The Macro Man
  • Solved
VBA Script - Return to named file
Replies
6
Views
127
mumps
mumps

Forum statistics

Threads
1,215,047
Messages
6,122,858
Members
449,096
Latest member
Erald

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