Help with macro automation

[stolenweasel]

Hello I can't find anything that quite fits what I'm looking for on this project. I have a workbook which tracks Aircraft airspace and site usage. The workbook contains 31 sheets (days) of data that is input by multiple employees. Each sheet has formulas to total up data in multiple fields. The last sheet is all formulas for monthly totals.

I would like to have a macro that takes one of these workbooks and spits out 12 identical workbooks labeled for the month and year. This is a fiscal year system, so I would put these in October through September order in a folder labeled 2025. Each sheet also needs to be write protected be cause we have some folks that can't help themselves of inadvertently erasing formulas and resizing boxes, etc. Thank you for your help. This is a few steps above my level.

Template - there should.be a macro in here to protect/unprotect all sheets

Dropbox

www.dropbox.com

R/S
Jeff George

 

[stolenweasel]

Yes the monthly totals sheet is pretty much the same as the daily sheets. Inhave a start and end sheet and the monthly totals uses the start and end sum feature for each cell. So ideally a workbook that is setup exactly the same as the monthly ones that has an annual sheet already in it, then the 12 monthly total sheets get pulled in with the data it has. Then the annual sheet could use the same method to give the annual totals. The only thing I wonder is since the data in the monthly total sheets is dependent upon the formulas when it's extracted would it loose the data?

The new macro names the files like puts a 01 in front of January. The way we have it is the 01 is paired woth October as in it is the first month of the Fiscal year. So "01 Oct 2024" and January 2025 would have 04 in front. This way they stay sorted properly in the folder. What you did was great though because that is an easy fix after they are created.

 

[mumps]

Try:

Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim x As Long, y As Long, z As Long, mName As String, sYear As String, myPath As String
    y = 1: z = 4
    sYear = InputBox("Please enter the year.")
    If sYear = "" Then Exit Sub
    myPath = "C:\Test\"
    For x = 1 To 12
        mName = MonthName(x, False)
        Select Case mName
            Case "October", "November", "December"
                ActiveWorkbook.SaveCopyAs Filename:=myPath & "0" & y & " " & mName & "-" & sYear - 1 & ".xlsm"
                y = y + 1
            Case Else
                ActiveWorkbook.SaveCopyAs Filename:=myPath & "0" & z & " " & mName & "-" & sYear & ".xlsm"
                z = z + 1
        End Select
    Next x
    Application.ScreenUpdating = True
End Sub

Looking into the annual workbook question.

 

[mumps]

Click here for your file. In order for this macro to work properly, you will need to create a folder which will contain only the attached file and the 12 monthly files. You could create a folder for each year. You can run the macro at any time and it will give you the running totals for whatever number of monthly files are in the folder. Of course, when you run it at the end of the year it will give you your final results. This is the code that is in the file:

Sub AnnualTotals()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, fName As String, r As Long, c As Long, srcRng As Range, rng As Range
    Dim v As Variant, v2 As Variant, v3 As Variant, arr() As Variant, arr2() As Variant, arr3() As Variant
    Set desWS = ThisWorkbook.Sheets("Annual Totals")
    ReDim arr(1 To 34, 1 To 27)
    ReDim arr2(1 To 48, 1 To 27)
    ReDim arr3(1 To 5, 1 To 27)
    Const strPath As String = "C:\Test\"
    ChDir strPath
    fName = Dir(strPath & "*.xlsm")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set srcWB = Workbooks.Open(strPath & fName)
            With srcWB.Sheets("Monthly Totals")
                v = .Range("B3:AB36").Value
                For r = LBound(v) To UBound(v)
                    For c = LBound(v, 2) To UBound(v, 2)
                        arr(r, c) = arr(r, c) + v(r, c)
                    Next c
                Next r
                v2 = .Range("B40:AB87").Value
                For r = LBound(v2) To UBound(v2)
                    For c = LBound(v2, 2) To UBound(v2, 2)
                        arr2(r, c) = arr2(r, c) + v2(r, c)
                    Next c
                Next r
                v3 = .Range("B89:AB93").Value
                For r = LBound(v3) To UBound(v3)
                    For c = LBound(v3, 2) To UBound(v3, 2)
                        arr3(r, c) = arr3(r, c) + v3(r, c)
                    Next c
                Next r
                Set srcRng = Union(.Range("E107:E108"), .Range("I107:I110"), .Range("E114:E115"))
                For Each rng In srcRng
                    With desWS
                        .Range(rng.Address) = .Range(rng.Address) + rng
                    End With
                Next rng
            End With
            srcWB.Close savechanges:=False
        End If
        fName = Dir
    Loop
    With desWS
        .Range("B3").Resize(UBound(v), UBound(v, 2)) = arr
        .Range("B40").Resize(UBound(v2), UBound(v2, 2)) = arr2
        .Range("B89").Resize(UBound(v3), UBound(v3, 2)) = arr3
        .Range("L1,S1,W1,AA1").EntireColumn.ClearContents
        .Rows(90).ClearContents
        .Rows(92).ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

 

[stolenweasel]

Click here for your file. In order for this macro to work properly, you will need to create a folder which will contain only the attached file and the 12 monthly files. You could create a folder for each year. You can run the macro at any time and it will give you the running totals for whatever number of monthly files are in the folder. Of course, when you run it at the end of the year it will give you your final results. This is the code that is in the file:

Sub AnnualTotals()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, fName As String, r As Long, c As Long, srcRng As Range, rng As Range
    Dim v As Variant, v2 As Variant, v3 As Variant, arr() As Variant, arr2() As Variant, arr3() As Variant
    Set desWS = ThisWorkbook.Sheets("Annual Totals")
    ReDim arr(1 To 34, 1 To 27)
    ReDim arr2(1 To 48, 1 To 27)
    ReDim arr3(1 To 5, 1 To 27)
    Const strPath As String = "C:\Test\"
    ChDir strPath
    fName = Dir(strPath & "*.xlsm")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set srcWB = Workbooks.Open(strPath & fName)
            With srcWB.Sheets("Monthly Totals")
                v = .Range("B3:AB36").Value
                For r = LBound(v) To UBound(v)
                    For c = LBound(v, 2) To UBound(v, 2)
                        arr(r, c) = arr(r, c) + v(r, c)
                    Next c
                Next r
                v2 = .Range("B40:AB87").Value
                For r = LBound(v2) To UBound(v2)
                    For c = LBound(v2, 2) To UBound(v2, 2)
                        arr2(r, c) = arr2(r, c) + v2(r, c)
                    Next c
                Next r
                v3 = .Range("B89:AB93").Value
                For r = LBound(v3) To UBound(v3)
                    For c = LBound(v3, 2) To UBound(v3, 2)
                        arr3(r, c) = arr3(r, c) + v3(r, c)
                    Next c
                Next r
                Set srcRng = Union(.Range("E107:E108"), .Range("I107:I110"), .Range("E114:E115"))
                For Each rng In srcRng
                    With desWS
                        .Range(rng.Address) = .Range(rng.Address) + rng
                    End With
                Next rng
            End With
            srcWB.Close savechanges:=False
        End If
        fName = Dir
    Loop
    With desWS
        .Range("B3").Resize(UBound(v), UBound(v, 2)) = arr
        .Range("B40").Resize(UBound(v2), UBound(v2, 2)) = arr2
        .Range("B89").Resize(UBound(v3), UBound(v3, 2)) = arr3
        .Range("L1,S1,W1,AA1").EntireColumn.ClearContents
        .Rows(90).ClearContents
        .Rows(92).ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

Wow thanks alot, I am off for the next couple days. When inget back in to work I will check it out and get back to you. I Really appreciate it.

 

[stolenweasel]

Click here for your file. In order for this macro to work properly, you will need to create a folder which will contain only the attached file and the 12 monthly files. You could create a folder for each year. You can run the macro at any time and it will give you the running totals for whatever number of monthly files are in the folder. Of course, when you run it at the end of the year it will give you your final results. This is the code that is in the file:

Sub AnnualTotals()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, fName As String, r As Long, c As Long, srcRng As Range, rng As Range
    Dim v As Variant, v2 As Variant, v3 As Variant, arr() As Variant, arr2() As Variant, arr3() As Variant
    Set desWS = ThisWorkbook.Sheets("Annual Totals")
    ReDim arr(1 To 34, 1 To 27)
    ReDim arr2(1 To 48, 1 To 27)
    ReDim arr3(1 To 5, 1 To 27)
    Const strPath As String = "C:\Test\"
    ChDir strPath
    fName = Dir(strPath & "*.xlsm")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set srcWB = Workbooks.Open(strPath & fName)
            With srcWB.Sheets("Monthly Totals")
                v = .Range("B3:AB36").Value
                For r = LBound(v) To UBound(v)
                    For c = LBound(v, 2) To UBound(v, 2)
                        arr(r, c) = arr(r, c) + v(r, c)
                    Next c
                Next r
                v2 = .Range("B40:AB87").Value
                For r = LBound(v2) To UBound(v2)
                    For c = LBound(v2, 2) To UBound(v2, 2)
                        arr2(r, c) = arr2(r, c) + v2(r, c)
                    Next c
                Next r
                v3 = .Range("B89:AB93").Value
                For r = LBound(v3) To UBound(v3)
                    For c = LBound(v3, 2) To UBound(v3, 2)
                        arr3(r, c) = arr3(r, c) + v3(r, c)
                    Next c
                Next r
                Set srcRng = Union(.Range("E107:E108"), .Range("I107:I110"), .Range("E114:E115"))
                For Each rng In srcRng
                    With desWS
                        .Range(rng.Address) = .Range(rng.Address) + rng
                    End With
                Next rng
            End With
            srcWB.Close savechanges:=False
        End If
        fName = Dir
    Loop
    With desWS
        .Range("B3").Resize(UBound(v), UBound(v, 2)) = arr
        .Range("B40").Resize(UBound(v2), UBound(v2, 2)) = arr2
        .Range("B89").Resize(UBound(v3), UBound(v3, 2)) = arr3
        .Range("L1,S1,W1,AA1").EntireColumn.ClearContents
        .Rows(90).ClearContents
        .Rows(92).ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

I'm not able to download that file to my phone and definitely can't access on work computer. I'm not familiar with app.box at all

 

[stolenweasel]

Ok so I figured out there was an app for Box, however I can't get a macro enabled workbook on to a work computer I have to build the macro on the computer. Is that just a blank copy of one of my sheets?

 

[mumps]

You must be able to enable macros in order for the file to work for you. The file contains one macro in Module1 and only one sheet, "Annual Totals". You will notice that all formulae are gone and the cells are blank. You should save the file in a separate folder as a blank template a copy of which is to be placed in the folder containing the 12 monthly files. When you run the macro, it will access the Monthly Totals sheets in each of the 12 monthly files and total the values in the "Annual Totals" sheet.

 

[stolenweasel]

You must be able to enable macros in order for the file to work for you. The file contains one macro in Module1 and only one sheet, "Annual Totals". You will notice that all formulae are gone and the cells are blank. You should save the file in a separate folder as a blank template a copy of which is to be placed in the folder containing the 12 monthly files. When you run the macro, it will access the Monthly Totals sheets in each of the 12 monthly files and total the values in the "Annual Totals" sheet.

Ok I got it figured out I had to copy one of my sheets and paste it to a blank workbook then paste in the module. I didn't remove the formulas for that sheet so I may need to look at that. It seemed to work though I just have to spot check and make sure everything is getting calculated. I ran out of time so I'll mess with it again tonight. Thank you very much.

 

[mumps]

You are very welcome.