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

That worked but i would like to have the data horizontal per file
 
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Try:
Code: 
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim x As Long
    x = 1
    Const strPath As String = "C:\Users\Brent.WSN\Downloads\Dukes Tournament of Champions\Weekly\"
    ChDir strPath
    strExtension = Dir("*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("16 Man Bracket").Range("AX20:AX25").Copy
            wkbDest.Sheets("Summary").Cells(x, 1).PasteSpecial Transpose:=True
            x = x + 1
            .Sheets("32 Man Bracket").Range("BJ26:BJ31").Copy
            wkbDest.Sheets("Summary").Cells(x, 1).PasteSpecial Transpose:=True
            x = x + 1
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
This macro will import the data from all your source files without having to select each one separately. Place the macro in a regular module in your destination workbook and save it as a macro-enabled file.
 
Last edited:
Upvote 0
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 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 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, Transpose:=True

                        '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("G" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True


            '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
D3allamerican07 said:
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 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 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, Transpose:=True

                        '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("G" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True


            '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...

Worked great!!! One last thing can it put the data in the active worksheet instead of a new file.
 
Upvote 0
Yes, it is now updated. Just put the macro in the module of your active workbook and keep it open before you run. It will look at the active workbook and paste the data in whatever workbook is open at the time you hit run.

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
    
    Set wkbDest = ThisWorkbook
    
    '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 variable sheet
                    LR = wkbDest.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
                        wkbDest.Sheets("Summary").Range("A" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True

                        '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
                       wkbDest.Sheets("Summary").Range("G" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True


            '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
D3allamerican07 said:
Yes, it is now updated. Just put the macro in the module of your active workbook and keep it open before you run. It will look at the active workbook and paste the data in whatever workbook is open at the time you hit run.

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
    
    Set wkbDest = ThisWorkbook
    
    '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 variable sheet
                    LR = wkbDest.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
                        wkbDest.Sheets("Summary").Range("A" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True

                        '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
                       wkbDest.Sheets("Summary").Range("G" & LR + 1).PasteSpecial xlPasteValues, Transpose:=True


            '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...

Thank you so much for your help!!! Greatly appreciated!!
 
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
1K
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
157
mumps
mumps
Y
  • Question Question
Consolidate all values from specific sheets into 1 master excel file
Replies
1
Views
269
Trebor76
T
A
  • Question Question
Macro to import the same sheets names are repeated across files.
Replies
0
Views
86
Amer Omar
A
R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
278
Ramadan2512
R

Forum statistics

Threads
1,224,825
Messages
6,181,189
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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