VBA Script to Rollup Data to a Master WorkBook

Question

I need to write a VBA script to loop through a specified directory containing a number of workbooks and copy a set range from different numbers of worksheets to a Master File that updates with new values.

I am fairly new to VBA and have searched for hours on a number of sites to try to find out what I am doing wrong. After all this time on StackOverflow, I figured I would just pose the question (hopefully with the push of a button once I get the code working).

I have attached my code so far.

It only includes code to pull data from the first workbook, but I am having trouble getting the code to perform the expected behavior.

I can get it to compile, but it doesn't get new values.

 Sub MasterRollup()

    Dim MyFile As String, MyFiles As String, FilePath As String
    Dim wbMaster As Workbook, wbTemp As Workbook
    Dim wsMaster As Worksheet, wsTemp As Worksheet
    Dim DataRange As Range, OutRange As Range
    Dim OutBook As Workbook, OutSheet As Worksheet
    Dim ctr As Integer

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    FilePath = "C:\Users\Temp"
    MyFiles = "C:\Users\Temp"
    MyFile = Dir(MyFiles)
    Set OutBook = Workbooks.Open("C:\Users\Temp\OutputWorkbook.xlsx")
    Set OutSheet = OutBook.Sheets(1)
    ctr = 1

         Set wbMaster = OutBook
         Set wsMaster = OutBook.Sheets(1)


        If MyFile = "FileName1.xlxs" Then
            '~~> Open the file and set variable
            Set wbTemp = Workbooks.Open(FilePath & MyFile, True)
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G18:S18")
            Set OutRange = OutSheet.Range("B5:N5")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Close the opened file
            wbTemp.Close False 'set to false, because opened as read-only
            Set wsTemp = Nothing
            Set wbTemp = Nothing
            ctr = ctr + 1
        End If


    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    OutBook.SaveAs

    End Sub

Edit:

I have tried to incorporate some of the feedback I received and checked out the link that was posted. I have tried to modify my code and am still not seeing the expected behavior. The code compiles, but no data appears in the Output workbook. Any help would be much appreciated. In the meantime, I'll keep searching :)

   Sub MasterRollup()

  Dim MyFile As String, MyFiles As String, FilePath As String
  Dim wbMaster As Workbook, wbTemp As Workbook
  Dim wsMaster As Worksheet, wsTemp As Worksheet
  Dim DataRange As Range, OutRange As Range
  Dim OutBook As Workbook, OutSheet As Worksheet
  Dim ctr As Integer, myExtension As String

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

FilePath = "C:\Users\Test"
MyFiles = "C:\Users\Test"
myExtension = "*.xlsx"
Set OutBook = Workbooks.Open("C:\Users\Test.xlsx")
Set OutSheet = OutBook.Sheets(1)
ctr = 1

     Set wbMaster = OutBook
     Set wsMaster = OutBook.Sheets(1)

MyFile = Dir(FilePath & myExtension)

Do While MyFile <> ""
    If MyFile = "File 1.xlsx" Then
        '~~> Open the file and set variable
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
        '~~> Sheet 1
        Set wsTemp = wbTemp.Sheets(1)
        Set DataRange = wsTemp.Range("G18:S18")
        Set OutRange = OutSheet.Range("B5:N5")
        DataRange.Copy
        OutRange.PasteSpecial xlPasteValues
        '~~> Close the opened file
        wbTemp.Close False 'set to false, because opened as read-only
        Set wsTemp = Nothing
        Set wbTemp = Nothing
        ctr = ctr + 1
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 2.xlsx" Then
        '~~> Open the file and set variable
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1 
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G17:S17")
            Set OutRange = OutSheet.Range("B6:N6")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 2 
            Set wsTemp = wbTemp.Sheets(2)
            Set DataRange = wsTemp.Range("G10:S10")
            Set OutRange = OutSheet.Range("B7:N7")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 3 
            Set wsTemp = wbTemp.Sheets(3)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B8:N8")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 4 
            Set ws.Temp = wbTemp.Sheets(4)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B9:N9")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 5 
            Set ws.Temp = wbTemp.Sheets(5)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B10:N10")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 6 
            Set ws.Temp = wbTemp.Sheets(6)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B11:N11")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 7 
            Set ws.Temp = wbTemp.Sheets(7)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B12:N12")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 8 
            Set ws.Temp = wbTemp.Sheets(8)
            Set DataRange = wsTemp.Range("G9:S9")
            Set OutRange = OutSheet.Range("B13:N13")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        wbTemp.Close False 'set to false, because opened as read-only
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        ctr = ctr + 1
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 3.xlsx" Then
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1 
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B14:N14")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        wbTemp.Close False 'set to false, because opened as read-only
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        ctr = ctr + 1
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 4.xlsx" Then
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B15:N15")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        wbTemp.Close False 'set to false, because opened as read-only
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        ctr = ctr + 1
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 5.xlsx" Then
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1 
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B16:N16")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        ctr = ctr + 1
        wbTemp.Close False 'set to false, because opened as read-only
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 6.xlsx" Then
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1 
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B17:N17")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 2 
            Set wsTemp = wbTemp.Sheets(2)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B18:N18")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 3 
            Set wsTemp = wbTemp.Sheets(3)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B19:N19")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 4 
            Set wsTemp = wbTemp.Sheets(4)
            Set DataRange = wsTemp.Range("G22:S22")
            Set OutRange = OutSheet.Range("B20:N20")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        wbTemp.Close False 'set to false, because opened as read-only
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        ctr = ctr + 1
    End If
    MyFile = Dir(FilePath & myExtension)
    If MyFile = "File 7.xlsx" Then
        Set wbTemp = Workbooks.Open(FilePath & MyFile, ReadOnly:=True)
            '~~> Sheet 1 
            Set wsTemp = wbTemp.Sheets(1)
            Set DataRange = wsTemp.Range("G18:S18")
            Set OutRange = OutSheet.Range("B21:N21")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
            '~~> Sheet 2 
            Set wsTemp = wbTemp.Sheets(2)
            Set DataRange = wsTemp.Range("G19:S19")
            Set OutRange = OutSheet.Range("B22:N22")
            DataRange.Copy
            OutRange.PasteSpecial xlPasteValues
        wbTemp.Close False 'set to false, because opened as read-only
        Set wsTemp = Nothing
        Set wbTemp = Nothing
    End If

    Loop

MsgBox ("Task Completed!")

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

OutBook.Close SaveChanges:=True

Workbooks.Open ("C:\Users\Test.xlsx")

End Sub

Thanks again!

Welcome to SO. You haven't run the loop to go through all the files. You need to tell what is working and what not. — ManishChristian, Sep 02 '15 at 01:02
Take a look at this and see if you can make sense of it: http://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba — Nick.Mc, Sep 02 '15 at 01:15

VBA Script to Rollup Data to a Master WorkBook

0 Answers0