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

[omar7]

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!!!

 

[zeromax1]

Hi Mumps, there is an error when I select an excel. The following sentence are high light by VBA itself.

If filename = False Then

This revised version should take care of both problems.

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

 

[mumps]

Try:

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 Not IsArray(FileName) Then
        MsgBox "No File Selected"
        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

 

[zeromax1]

Thank you. Everything is work.

Try:

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 Not IsArray(FileName) Then
        MsgBox "No File Selected"
        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

 

[mumps]

My pleasure.