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

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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

F
  • Solved
VBA to open all files in a folder, put the file's name in a cell and copy it to another opened workbook
Replies
5
Views
144
feni1388
F
D
  • Question
VBA - Open Files then copy specific cells into a new row.
Replies
1
Views
243
dhubz
D
M
  • Solved
Copy the last sheet from file to another with ignore empty whole column
Replies
7
Views
187
mumps
mumps
B
  • Solved
VBA copy and paste as values and save as new file based on table list
Replies
4
Views
117
Peter_SSs
Peter_SSs
H
  • Solved
How to copy data from one file and paste it into a dynamically named workbook
Replies
3
Views
235
dermie_72
D

Forum statistics

Threads
1,215,575
Messages
6,125,619
Members
449,238
Latest member
wcbyers

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