Monthly Rollup of data

[singlgl1]

I'm gonna try to word this so that it makes sense so forgive me if I fail to do so.
I have a daily file that contains a sheet named "events" that captures gas volumes vented throughout the day.The files are named 6-1-11, 6-2-11,etc throughout the month.Some days may have no events and some may have one or more.There are rows on each daily sheet for up to 21 events during the day(cells A5:T25 ). Now what I would like to do is rollup each event onto one "monthly" sheet in a separate workbook at the end of the month.I'd like to tell it to go and look at each of these files for the month (6-1-11,6-2-11, and so on and look at sheet "events" and pull in only the info on rows A5:T25 where the corresponding cell in column A is populated.I'm assuming this wouyld be some kind of lookup function but need some guidance from the pros out there.
I appreciate any feedback and will provide files and more info if necessary.
Thanks Again !!

 

[pbornemeier]

I believe this will do as you asked:

Option Explicit

Sub DevelopMonthlyRollup()

    Dim lX As Long
    Dim lNextWriteRow As Long
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Rollup").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(before:=Sheets(1)).Name = "Rollup"

    'Replace quoted column letters with appropriate column head titles
    'or leave alone if no headers required - a header row is needed
    Worksheets("Rollup").Range("A1").Resize(1, 20).Value = Array( _
        "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", _
        "L", "M", "N", "O", "P", "Q", "R", "S", "T")
    
    lNextWriteRow = 2
    
    For lX = 1 To Sheets.Count
        With Sheets(lX)
            If .Name <> "Rollup" Then
                .Select
                .AutoFilterMode = False
                With .Range("A5:T25")
                    .Copy Destination:=Worksheets("Rollup").Cells(lNextWriteRow, 1)
                End With
                .AutoFilterMode = False
                Worksheets("Rollup").Select
                lNextWriteRow = Worksheets("Rollup").Cells(Rows.Count, 1).End(xlUp).Row + 1
            End If
        End With
    Next
    
    'Delete Rollup worksheet's rows with blank column A
    ActiveSheet.AutoFilterMode = False
    With Worksheets("Rollup").Range("A1:T" & lNextWriteRow)
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:="="
    End With
    With Worksheets("Rollup").Range("A2:T" & lNextWriteRow)
        .SpecialCells(xlCellTypeVisible).Select
        .EntireRow.Delete
    End With
    ActiveSheet.AutoFilterMode = False
    Range("A1").Select
    
End Sub

 

[singlgl1]

The sheets(Events) that I would like to roll up into a "monthly" file are located on 31 different files(for May) named by the day of month(5-1-11,5-2-11, etc.).The "monthly" file would be a standalone file that will be created monthly and needs to look at the sheet "events" from each of the files 5-1-11 thru 5-31-11, cells A5:T25 where the corresponding cell in column A is populated and put this info into rows on the monthly file.
ON the monthly file there may be more or less than 31 rows of data based on the number of events from each days individual "events" sheets from files 5-1-11 thru 5-31-11.
If I knew how to post the files I would be glad to.
Pborneler,I may be misunderstanding your code.You may be telling me to put this code on each of the monthly files and perhaps it is going to export the appropriate data into the monthly file.I'm just not code savvy enough to tell but please let me know if I'm just not interpreting as intended. Thanks for the help!

Thanks!

 

[pbornemeier]

I read your original post incorrectly. My code will rollup all worksheets in a single file. I need a few questions answered to properly replace the code:
1) What is the name of the worksheet in the daily workbook that contains the data?
2) Is there any need to add a data column to show lines data came from which daily workbook, or is the date one of the columns already present?
3) are there any other files in the directory that holds the May files?
4) do you want the monthly files to end up in a particular directory, or in the directory that contains the daily files?
5) Do rows A5:T25 contain a header row? What data should be in row 1 of the monthly worksheet?
6) What should the worksheet in the Monthly workbook be named?
7) Would you want to consolidate all monthlies (or all monthlies in a given year) into a single workbook?
8) Does the order of the data in the monthly worksheet matter?
9) What directory are the daily files in?
10) What version of Excel are you using?
11) What is the file extension of the daily files (.xls, .xlsb, .xlsx ?)

Note: I have found that when I create files based on a date it is beneficial to use a YYYYMMDD filename so it is easy to sort in date order.

 

[singlgl1]

Phil, I truly appreciate you taking the time you have to help. I hope I'm not making this too complicated.Hope these answers can help:
1) The actual name to be used for the worksheet will be "Flare & Vent Tracking"
2) The date will be one of the columns (Column A) in the monthly file.
3)There is a file for each day of the month filed in this same path H:\Morning Reports 2011\May\5-1-11.xls
This is the only location for the May (daily) files.
4) I would like the monthly file to end up in the same directory.
5) Actually the Header is in row 3 of the daily file.
Row 1 of the monthly worksheet will have a header exactly as the header from the daily files, with this exception:Row 1 of the monthly will need the date
in column A( could be put into Column U if it makes it easier)The header from the daily sheet doesn’t have a date column per say but rather has the date in
cell G1 since all the data in the daily sheets are only for that particular date there was no need to have a date column ,where the monthly rollup sheet
will however.
6) The worksheet in the monthly workbook currently is named "monthly rollup"
7) each monthly will reside within the directory that contains the daily files( See path for May in #3) each month is filed in the same fashion.
8) I would like for the order of the data to mimic the order of the data as it is on the daily file sheets with the exception of adding the date column.
9)See # 3 above.
10) Using Excel 2007
11) The daily files use .xls extensions.
Note) Since there are several other files and users that reference these daily files, I don't have the option of changing the file naming convention.

Thanks again for your patience!!

 

[pbornemeier]

Still more questions.

1) From what you said, I understand that columns A-T in the daily files should be copied to columns B-U in the monthly, with the appropriate date added to column A by the program as the data is copied. Is that correct?

2) In the daily files, do rows 5-25 fill sequentially? Can their be gaps between filled rows?

3) Is there any macro code in the daily files?

 

[singlgl1]

1) That is all correct.
2)Rows are filled sequentially as there are events. There would be no gaps between filled rows.
3) there are a couple of macros within the daily files but none that pertain to the sheet involved here.


Thanks-Greg !

 

[pbornemeier]

There is some error checking in here, but it does not account for every possibility. Please let me know how it works.

Option Explicit
 
Sub CreateMonthlyFileFromDailyFiles()
 
    Dim strSourceWorksheetName As String
    Dim strMonthlyRollupWorksheetName As String
    Dim lNextWriteRow As Long
    Dim bBadInput As Boolean
    Dim iMonth As Integer
    Dim iYear As Integer
    Dim sInput As String
    Dim strFileDirectory As String
    Dim iAnswer As Integer
    Dim iVisibleWindows As Integer
    Dim lX As Long
    Dim strFileName As String
    Dim bFound As Boolean
    Dim lY As Long
    Dim lDataRowCount  As Long
    Dim lLinesCopied As Long
    Dim sOK As String
    Dim sNoWorksheet As String
    Dim sNoFile As String
    Dim sPreface As String
    Dim sReport As String
 
    strSourceWorksheetName = "Flare & Vent Tracking"
    strMonthlyRollupWorksheetName = "Monthly Rollup"
    lNextWriteRow = 2
 
    ThisWorkbook.Activate
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(strMonthlyRollupWorksheetName).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Worksheets.Add(before:=Sheets("Sheet1")).Name = strMonthlyRollupWorksheetName
 
    bBadInput = True
    Do While bBadInput
        sInput = InputBox("Enter the Month to process (1-12), X to cancel.", "Enter Month", Format(Now(), "m"))
        If UCase(sInput) = "X" Then GoTo End_Sub
        If Not IsNumeric(sInput) Then sInput = 0
        If CInt(sInput) >= 1 And CInt(sInput) <= 12 Then
            iMonth = CInt(sInput)
            bBadInput = False
        End If
    Loop
    bBadInput = True
    Do While bBadInput
        sInput = InputBox("Enter the 4-digit Year to process, X to cancel.", "Enter Year", Format(Now(), "yyyy"))
        If UCase(sInput) = "X" Then GoTo End_Sub
        If Not IsNumeric(sInput) Then sInput = 0
        If CInt(sInput) >= 1900 And CInt(sInput) <= 2100 Then
            iYear = CInt(sInput)
            bBadInput = False
        End If
    Loop
    strFileDirectory = "H:\Morning Reports " & iYear & "\" & Format(DateSerial(2010, iMonth, 1), "mmm") & "\"
 
    'For local testing
    strFileDirectory = "C:\PAB\Morning Reports " & iYear & "\" & Format(DateSerial(2010, iMonth, 1), "mmm") & "\"
 
    'Close other workbooks - they may be ones we want to process
    'and we don't want to overwrite them.
    If Windows.Count > 1 Then
        iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
            "   OK     to close all other workbooks and continue, or" & vbCrLf & _
            "   Cancel to stop this macro.", vbOKCancel + _
            vbDefaultButton1 + vbExclamation, "Continue ?")
    End If
    If iAnswer = vbCancel Then
        GoTo End_Sub
    Else
        iVisibleWindows = Windows.Count
        For lX = Windows.Count To 1 Step -1
            If Windows(lX).Caption <> ThisWorkbook.Name Then
                If Windows(lX).Visible Then
                'if workbook modified user will get
                'chance to save or cancel for each
                    Windows(lX).Close
                End If
                iVisibleWindows = iVisibleWindows - 1
            End If
        Next
    End If
 
    'See if user chose Cancel for any close requests
    If iVisibleWindows > 1 Then
        MsgBox "Other Excel workbooks are still open. " & _
            "Close other workbooks and try again", , "Process Cancelled."
        GoTo End_Sub
    End If
 
    ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("A1").Value = "Date"
    'Process daily workbooks
    For lX = 1 To Day(DateSerial(iYear, iMonth + 1, 1) - 1) '1 To last day of the month
        strFileName = strFileDirectory & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
        If Dir(strFileName) <> "" Then
             Workbooks.Open Filename:=strFileName
            'Process file
            bFound = False
            For lY = 1 To Worksheets.Count
                If Worksheets(lY).Name = strSourceWorksheetName Then
                    bFound = True
                    Exit For
                End If
            Next
 
            If bFound Then
                'Copy header if not already copied
                If ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("B1").Value = "" Then
                    Worksheets(strSourceWorksheetName).Range("A3:T3").Copy _
                        Destination:=ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("B1")
                End If
                'Copy data
                Worksheets(strSourceWorksheetName).Activate
                Range("A1").Select 'in case workbook was saved with an object selected
                lDataRowCount = Application.WorksheetFunction.CountA(Worksheets(strSourceWorksheetName).Range("A5:A25"))
                If lDataRowCount > 0 Then
                    Worksheets(strSourceWorksheetName).Range("A5:T" & 4 + lDataRowCount).Copy _
                        Destination:=ThisWorkbook.Sheets(strMonthlyRollupWorksheetName).Cells(lNextWriteRow, 2)
                    With ThisWorkbook.Sheets(strMonthlyRollupWorksheetName)
                        .Range(.Cells(lNextWriteRow, 1), .Cells(lNextWriteRow + lDataRowCount - 1, 1)).Value = _
                        Format(DateSerial(iYear, iMonth, lX), "mm/dd/yy")
                    End With
                End If
                lLinesCopied = lLinesCopied + lDataRowCount
 
                'Write Date+rows copied to status report
                sOK = sOK & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls" & " " & vbTab & lDataRowCount & " events"
 
            Else
                'Write date + "source worksheet not found
                sNoWorksheet = sNoWorksheet & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
 
            End If
            ActiveWorkbook.Saved = True
            ActiveWorkbook.Close
 
        Else
            'Write Missing Date to status report
            sNoFile = sNoFile & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
        End If
 
 
        lNextWriteRow = ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
 
    Next
 
    With ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName)
        .Columns("A:U").EntireColumn.AutoFit
        .Range("A1").Activate
    End With
 
    sPreface = Format(DateSerial(iYear, iMonth, 1), "mmmm yyyy") & " Daily Event Rollup Report" & vbLf
    If sOK <> "" Then sReport = sOK & vbLf & vbTab & vbTab & "------" & vbLf & _
         "Events Copied" & vbTab & lLinesCopied
    If sNoWorksheet <> "" Then sReport = sReport & vbLf & vbLf & _
        "The following workbooks did not contain a worksheet named '" & _
        strSourceWorksheetName & "'" & vbLf & sNoWorksheet
    If sNoFile <> "" Then sReport = sReport & vbLf & vbLf & _
        "The following workbooks did not exist in" & vbLf & _
        strFileDirectory & vbLf & sNoFile
    Sheets(strMonthlyRollupWorksheetName).Copy
    MsgBox sPreface & sReport
 
    On Error Resume Next
    If Len(sOK) > 0 Then
        ActiveWorkbook.SaveAs Filename:= _
            strFileDirectory & "Monthly Report as of " & Format(Now(), "m-d-yy") & ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
 
    Else
        MsgBox "No daily files in " & strFileDirectory
    End If
    On Error GoTo 0
 
    With ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName)
        .UsedRange.Clear
        For lX = .Shapes.Count To 1 Step -1
            .Shapes(lX).Delete
        Next
    End With
 
End_Sub:
End Sub

 

[pbornemeier]

Added to code to disable the need to answer the macro questions whenever daily files are opened. Removed some testing code.

Option Explicit
 
Sub CreateMonthlyFileFromDailyFiles()
 
    Dim strSourceWorksheetName As String
    Dim strMonthlyRollupWorksheetName As String
    Dim lNextWriteRow As Long
    Dim bBadInput As Boolean
    Dim iMonth As Integer
    Dim iYear As Integer
    Dim sInput As String
    Dim strFileDirectory As String
    Dim iAnswer As Integer
    Dim iVisibleWindows As Integer
    Dim lX As Long
    Dim strFileName As String
    Dim bFound As Boolean
    Dim lY As Long
    Dim lDataRowCount  As Long
    Dim lLinesCopied As Long
    Dim sOK As String
    Dim sNoWorksheet As String
    Dim sNoFile As String
    Dim sPreface As String
    Dim sReport As String
    Dim secAutomation As MsoAutomationSecurity
 
    'Get default macro security setting
    secAutomation = Application.AutomationSecurity
 
    'Disable macros on files to be opened
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
 
    strSourceWorksheetName = "Flare & Vent Tracking"
    strMonthlyRollupWorksheetName = "Monthly Rollup"
    lNextWriteRow = 2
 
    ThisWorkbook.Activate
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(strMonthlyRollupWorksheetName).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Worksheets.Add(before:=Sheets("Sheet1")).Name = strMonthlyRollupWorksheetName
 
    bBadInput = True
    Do While bBadInput
        sInput = InputBox("Enter the Month to process (1-12), X to cancel.", "Enter Month", Format(Now(), "m"))
        If UCase(sInput) = "X" Then GoTo End_Sub
        If Not IsNumeric(sInput) Then sInput = 0
        If CInt(sInput) >= 1 And CInt(sInput) <= 12 Then
            iMonth = CInt(sInput)
            bBadInput = False
        End If
    Loop
    bBadInput = True
    Do While bBadInput
        sInput = InputBox("Enter the 4-digit Year to process, X to cancel.", "Enter Year", Format(Now(), "yyyy"))
        If UCase(sInput) = "X" Then GoTo End_Sub
        If Not IsNumeric(sInput) Then sInput = 0
        If CInt(sInput) >= 1900 And CInt(sInput) <= 2100 Then
            iYear = CInt(sInput)
            bBadInput = False
        End If
    Loop
    strFileDirectory = "H:\Morning Reports " & iYear & "\" & Format(DateSerial(2010, iMonth, 1), "mmm") & "\"
 
    'Close other workbooks - they may be ones we want to process
    'and we don't want to overwrite them.
    If Windows.Count > 1 Then
        iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
            "   OK     to close all other workbooks and continue, or" & vbCrLf & _
            "   Cancel to stop this macro.", vbOKCancel + _
            vbDefaultButton1 + vbExclamation, "Continue ?")
    End If
    If iAnswer = vbCancel Then
        GoTo End_Sub
    Else
        iVisibleWindows = Windows.Count
        For lX = Windows.Count To 1 Step -1
            If Windows(lX).Caption <> ThisWorkbook.Name Then
                If Windows(lX).Visible Then
                'if workbook modified user will get
                'chance to save or cancel for each
                    Windows(lX).Close
                End If
                iVisibleWindows = iVisibleWindows - 1
            End If
        Next
    End If
 
    'See if user chose Cancel for any close requests
    If iVisibleWindows > 1 Then
        MsgBox "Other Excel workbooks are still open. " & _
            "Close other workbooks and try again", , "Process Cancelled."
        GoTo End_Sub
    End If
 
    ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("A1").Value = "Date"
    'Process daily workbooks
    For lX = 1 To Day(DateSerial(iYear, iMonth + 1, 1) - 1) '1 To last day of the month
        strFileName = strFileDirectory & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
        If Dir(strFileName) <> "" Then
             Workbooks.Open Filename:=strFileName
            'Process file
            bFound = False
            For lY = 1 To Worksheets.Count
                If Worksheets(lY).Name = strSourceWorksheetName Then
                    bFound = True
                    Exit For
                End If
            Next
 
            If bFound Then
                'Copy header if not already copied
                If ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("B1").Value = "" Then
                    Worksheets(strSourceWorksheetName).Range("A3:T3").Copy _
                        Destination:=ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Range("B1")
                End If
                'Copy data
                Worksheets(strSourceWorksheetName).Activate
                Range("A1").Select 'in case workbook was saved with an object selected
                lDataRowCount = Application.WorksheetFunction.CountA(Worksheets(strSourceWorksheetName).Range("A5:A25"))
                If lDataRowCount > 0 Then
                    Worksheets(strSourceWorksheetName).Range("A5:T" & 4 + lDataRowCount).Copy _
                        Destination:=ThisWorkbook.Sheets(strMonthlyRollupWorksheetName).Cells(lNextWriteRow, 2)
                    With ThisWorkbook.Sheets(strMonthlyRollupWorksheetName)
                        .Range(.Cells(lNextWriteRow, 1), .Cells(lNextWriteRow + lDataRowCount - 1, 1)).Value = _
                        Format(DateSerial(iYear, iMonth, lX), "mm/dd/yy")
                    End With
                End If
                lLinesCopied = lLinesCopied + lDataRowCount
 
                'Write Date+rows copied to status report
                sOK = sOK & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls" & " " & vbTab & lDataRowCount & " events"
 
            Else
                'Write date + "source worksheet not found
                sNoWorksheet = sNoWorksheet & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
 
            End If
            ActiveWorkbook.Saved = True
            ActiveWorkbook.Close
 
        Else
            'Write Missing Date to status report
            sNoFile = sNoFile & vbLf & iMonth & "-" & lX & "-" & CInt(Right(CStr(iYear), 2)) & ".xls"
        End If
 
 
        lNextWriteRow = ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
 
    Next
 
    With ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName)
        .Columns("A:U").EntireColumn.AutoFit
        .Range("A1").Activate
    End With
 
    sPreface = Format(DateSerial(iYear, iMonth, 1), "mmmm yyyy") & " Daily Event Rollup Report" & vbLf
    If sOK <> "" Then sReport = sOK & vbLf & vbTab & vbTab & "------" & vbLf & _
         "Events Copied" & vbTab & lLinesCopied
    If sNoWorksheet <> "" Then sReport = sReport & vbLf & vbLf & _
        "The following workbooks did not contain a worksheet named '" & _
        strSourceWorksheetName & "'" & vbLf & sNoWorksheet
    If sNoFile <> "" Then sReport = sReport & vbLf & vbLf & _
        "The following workbooks did not exist in" & vbLf & _
        strFileDirectory & vbLf & sNoFile
    Sheets(strMonthlyRollupWorksheetName).Copy
    MsgBox sPreface & sReport
 
    On Error Resume Next
    If Len(sOK) > 0 Then
        ActiveWorkbook.SaveAs Filename:= _
            strFileDirectory & "Monthly Report as of " & Format(Now(), "m-d-yy") & ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
 
    Else
        MsgBox "No daily files in " & strFileDirectory
    End If
    On Error GoTo 0
 
    With ThisWorkbook.Worksheets(strMonthlyRollupWorksheetName)
        .UsedRange.Clear
        For lX = .Shapes.Count To 1 Step -1
            .Shapes(lX).Delete
        Next
    End With
 
End_Sub:
 
    'Restore default macro security setting
    Application.AutomationSecurity = secAutomation
End Sub

 

[singlgl1]

Phil, You are great.Thanks for the help.

As the code went through and opened each of the daily files (may), since each file had links within them, I was being prompted to Update or not to update each time it opened one.Can we add code that would tell ot not to update any files as they are being opened?
When it got to the end of the month opening the files(and I would click to update), it through an error up quickly then vanished.I'll go through the process again and see if I can catch what the error was.Again, thanks for your help.