Macro to open each workbook and copy specific cell to master book

omar7

New Member
Joined
Nov 18, 2012
Messages
23
Hi Guys,
I have about 800 workbooks saved in a specific folder, each with a different name.
There are two generic formats within these 800 workbooks.

I need to create a macro which will open each of the 800 booklets, then determines which format the booklet contains
and then copy paste special two cells from the booklet to my master sheet.

Basically the two formats have different tab names which i need the data from, the names of the tabs, and the cell contents to copy are:
format 1) Tab Name: Q4 Progress Review ( Copy cells B6 [to Cell A1] and C21 [to B1] )
format 2) Tab Name: Summary Sheet ( Copy cells D5 [to cell A1] and D48 [to cell B1] )

The code will need to open the first booklet in the folder, then
distinguish whether a tab name in the book is named either 1) "Q4 Progress Review" or 2) "Summary Sheet"
If it is named the first point, then it will copy cell B6 from the booklet to cell A1 in master file and cell C21 from booklet to cell B1 in master file..
Then the code will continue to the next booklet and loop (so that the 2nd booklet copies the data into cells A2 and B2 in the master file and so on...)

This has me totally stuck!!
I will be extremely greatful for anyone who can help me out with this.

Thanks in advance!!!
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,597
Hi omar7. Give this macro a try. There may be a few changes you will have to make to suit your situation. The code assumes that your source files are in a folder named "Test" ("C:\Test\"). Change the folder name in the macro to match yours. It also assumes that your Master file to which you are copying is not in the same folder as your source files. Otherwise it too will be searched. It also assumes that your source files have a xlsx extension (strExtension = Dir("*.xlsx")). Change this as well if necessary. Run the macro from your Master file. The copying will be done to "Sheet1" of your Master file. Change the sheet name in the code to match yours. With such a large number of files, I'm not sure how long it will take if it works properly for you.
Code:
Sub CopyRanges()
    Dim wbOpen As Workbook
    Const strPath As String = "C:\Test\"
    Dim strExtension As String
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath
    strExtension = Dir("*.xlsx")
        Do While strExtension <> ""
            Set wbOpen = Workbooks.Open(strPath & strExtension)
            With wbOpen
                For Each ws In Sheets
                    If ws.Name = "Q4 Progress Review" Then
                        Range("B6").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Range("C21").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    ElseIf ws.Name = "Summary Sheet" Then
                        Range("D5").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Range("D48").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    End If
                Next ws
                .Close SaveChanges:=False
            End With
            strExtension = Dir
        Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub
 

omar7

New Member
Joined
Nov 18, 2012
Messages
23
Hi omar7. Give this macro a try. There may be a few changes you will have to make to suit your situation. The code assumes that your source files are in a folder named "Test" ("C:\Test\"). Change the folder name in the macro to match yours. It also assumes that your Master file to which you are copying is not in the same folder as your source files. Otherwise it too will be searched. It also assumes that your source files have a xlsx extension (strExtension = Dir("*.xlsx")). Change this as well if necessary. Run the macro from your Master file. The copying will be done to "Sheet1" of your Master file. Change the sheet name in the code to match yours. With such a large number of files, I'm not sure how long it will take if it works properly for you.

Hi mumps, I have tried your code however nothing happens when i run it. I fixed the code in terms of my destination files, my code is:
Code:
Sub PrPMaster()
    Dim wbOpen As Workbook
    Const strPath As String = "C:\Users\muxa\Desktop\PRP TEST"
    Dim strExtension As String
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath
    strExtension = Dir("*.xlsx")
        Do While strExtension <> ""
            Set wbOpen = Workbooks.Open(strPath & strExtension)
            With wbOpen
                For Each ws In Sheets
                    If ws.Name = "Q4 Progress Review" Then
                        Range("B6").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Range("C21").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    ElseIf ws.Name = "Summary Sheet" Then
                        Range("D5").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Range("D48").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    End If
                Next ws
                .Close SaveChanges:=False
            End With
            strExtension = Dir
        Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub

Do you think the workbooks being protected has something to do with it?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,597
Try this version:
Code:
Sub PrPMaster()
    Dim wbOpen As Workbook
    Const strPath As String = "C:\Users\muxa\Desktop\PRP TEST"
    Dim strExtension As String
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath
    strExtension = Dir("*.xlsx")
        Do While strExtension <> ""
            Set wbOpen = Workbooks.Open(strPath & strExtension)
            With wbOpen
                .Unprotect
                For Each ws In Sheets
                    If ws.Name = "Q4 Progress Review" Then
                        ws.Range("B6").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        ws.Range("C21").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    ElseIf ws.Name = "Summary Sheet" Then
                        ws.Range("D5").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        ws.Range("D48").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    End If
                Next ws
                .Close SaveChanges:=False
            End With
            strExtension = Dir
        Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub
 

omar7

New Member
Joined
Nov 18, 2012
Messages
23

ADVERTISEMENT

Try this version:
Code:
Sub PrPMaster()
    Dim wbOpen As Workbook
    Const strPath As String = "C:\Users\muxa\Desktop\PRP TEST"
    Dim strExtension As String
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath
    strExtension = Dir("*.xlsx")
        Do While strExtension <> ""
            Set wbOpen = Workbooks.Open(strPath & strExtension)
            With wbOpen
                .Unprotect
                For Each ws In Sheets
                    If ws.Name = "Q4 Progress Review" Then
                        ws.Range("B6").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        ws.Range("C21").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    ElseIf ws.Name = "Summary Sheet" Then
                        ws.Range("D5").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        ws.Range("D48").Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    End If
                Next ws
                .Close SaveChanges:=False
            End With
            strExtension = Dir
        Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub

Hi mumps,

Still nothing.. I will pm you examples of two workbooks which i am working with
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,597
Hi Omar. Let's give this another try.
Code:
Sub PrPMaster()
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim MyPath As String
    Dim MyFile As String
    Application.ScreenUpdating = False
    Set wkbDest = ThisWorkbook
    MyPath = "C:\Users\muxa\Desktop\PRP TEST"
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    MyFile = Dir(MyPath & "*.xlsx")
    Do While Len(MyFile) > 0
        Set wkbSource = Workbooks.Open(MyPath & MyFile)
        With wkbSource
            For Each ws In Sheets
                If ws.Name = "Q4 Progress Review" Then
                    Range("B6").Copy
                    ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    Range("C21").Copy
                    ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                ElseIf ws.Name = "Summary Sheet" Then
                    Range("D5").Copy
                    ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    Range("D48").Copy
                    ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next ws
            Application.CutCopyMode = False
            .Close savechanges:=False
        End With
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Data copying has been completed.", vbInformation
End Sub
 
Last edited:

zeromax1

New Member
Joined
Mar 20, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hello, Mumps. I edit your code from other post and it only can select it one by one

I want to select the multi excel files at the same time. How can I do that ?

Thank you.

Hi Omar. Let's give this another try.
Code:
Option Explicit

Sub CopySheet()
Application.ScreenUpdating = False
Dim flder As FileDialog
Dim FileName As String
Dim FileChosen As Integer
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Set wkbDest = ThisWorkbook

OpenFile:
Set flder = Application.FileDialog(msoFileDialogFilePicker)
flder.Title = "Please Select an Excel File"
flder.InitialFileName = "c:\"
flder.InitialView = msoFileDialogViewSmallIcons
flder.Filters.Clear
flder.Filters.Add "Excel Files", "*.xlsx*"
MsgBox ("Select a folder and then a file to open.")
FileChosen = flder.Show
FileName = flder.SelectedItems(1)
 
Set wkbSource = Workbooks.Open(FileName)
wkbSource.Sheets("Source").Range("C6:AP" & Range("C" & Rows.Count).End(xlUp).Row).Copy
wkbDest.Sheets("MASTER").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Application.CutCopyMode = False
Application.ScreenUpdating = True
wkbSource.Close savechanges:=False
If MsgBox("Do you want to open another workbook?", vbYesNo) = vbYes Then GoTo OpenFile
End Sub
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,597
Try:
VBA Code:
Sub CopySheet()
    Application.ScreenUpdating = False
    Dim FileName As Variant, wkbSource As Workbook, wkbDest As Workbook
    Set wkbDest = ThisWorkbook
    FileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Select Excel Files", , True)
    For i = LBound(FileName) To UBound(FileName)
        Set wkbSource = Workbooks.Open(FileName(i))
        With wkbSource
            .Sheets("Source").Range("C6:AP" & .Range("C" & .Rows.Count).End(xlUp).Row).Copy
            wkbDest.Sheets("MASTER").Cells(wkbDest.Sheets("MASTER").Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wkbSource.Close savechanges:=False
        End With
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 

zeromax1

New Member
Joined
Mar 20, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows
Thank you very much mumps, I made some amendment to skip the warning from excel about the large information in the clip board.

On the other hand, if i cancel to select the excel file, it will be error and debug. should i add the on error to go code?

Try:
VBA Code:
Sub Consolidatfiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim FileName As Variant, wkbSource As Workbook, wkbDest As Workbook
    Set wkbDest = ThisWorkbook
    FileName = Application.GetOpenFilename("Excel Files (*.xlsx*),*.xlsx*", , "Select Excel Files", , True)
    For i = LBound(FileName) To UBound(FileName)
        Set wkbSource = Workbooks.Open(FileName(i))
        With wkbSource
            .Worksheets(1).Range("B6:AP" & Range("B" & Rows.Count).End(xlUp).Row).Copy
            wkbDest.Worksheets(1).Cells(wkbDest.Worksheets(1).Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
            wkbSource.Close savechanges = False
        End With
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,597
This revised version should take care of both problems.
VBA Code:
Sub CopySheet()
    Application.ScreenUpdating = False
    Dim FileName As Variant, wkbSource As Workbook, wkbDest As Workbook
    Set wkbDest = ThisWorkbook
    FileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Select Excel Files", , True)
    If FileName = False Then
        MsgBox ("You have not selected any files.")
        Exit Sub
    End If
    For i = LBound(FileName) To UBound(FileName)
        Set wkbSource = Workbooks.Open(FileName(i))
        With wkbSource
            .Sheets("Source").Range("C6:AP" & .Range("C" & .Rows.Count).End(xlUp).Row).Copy
            wkbDest.Sheets("MASTER").Cells(wkbDest.Sheets("MASTER").Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            wkbSource.Close savechanges:=False
        End With
    Next i
    Application.ScreenUpdating = True
End Sub
 

Forum statistics

Threads
1,137,298
Messages
5,680,689
Members
419,927
Latest member
Axtros

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
Top