User saving file wrong Causing VBA error

O

ohmedic88

Board Regular
Joined
Jun 24, 2013
Messages
124
Background I have a excel workbook that builds a monthly to do sheet with VBA macros... I also have Users that have only basic excel knowledge.

Problem... Users go in and save the workbook without the Macros enabled. This causes an error which results in the owner rebuilding the entire form from scratch.


I have some begginer VBA experience though rusty and I was hoping to find some solutions

Goal... Is there a way that I can Lock the Workbook format to be macro enabled save only? or
Is there a way to edit the code to get the system back on track without loosing the individual sheets.

Code
Code: 
'Create Schedule macros'  Will Singer


Public Sub CreateSchedule()
    Dim NewName As String
    'check to make sure there is a time entered for each row used
    For r = 6 To 38
        If Len(Trim(Cells(r, 6))) > 0 Then
            If Cells(r, 21).Value = 0 Then
                If Len(Trim(Cells(r, 8))) = 0 Then
                    MsgBox "Please enter a time for line " & Trim(CStr(r))
                Else
                    MsgBox "Please enter a time for component " & Cells(r, 8)
                End If
                Range("U" & Trim(CStr(r))).Select
                Exit Sub
            End If
        End If
    Next
    Sheets("Dates").Cells(2, 22) = False
    DialogSheets("dlgGetMonthYear").DialogFrame.Height = 115.5
    If DialogSheets("dlgGetMonthYear").Show = False Then
        Exit Sub
    End If
    Application.ScreenUpdating = False
    If Sheets("Dates").Cells(2, 22) = True Then
        NewName = "Week " & Sheets("Dates").Cells(3, 22) & " - " & Left(Trim(GetMonth(Sheets("Dates").Cells(3, 17))), 3) & ", " & GetYear(Sheets("Dates").Cells(3, 20))
    Else
        NewName = Left(Trim(GetMonth(Sheets("Dates").Cells(3, 17))), 3) & ", " & GetYear(Sheets("Dates").Cells(3, 20))
    End If
    'if sheet already exists, delete it
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(NewName).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    'create new sheet
    Sheets("ScheduleTemplate").Copy After:=Worksheets(Worksheets.Count)
    Sheets("ScheduleTemplate (2)").Visible = True
    Sheets("ScheduleTemplate (2)").Select
    Sheets("ScheduleTemplate (2)").Name = NewName
    'Fix month, year title
    Range("I5").Select
    ActiveCell.FormulaR1C1 = "=""Month: "" & GetMonth(Dates!R[-2]C[8]) & "", "" & GetYear(Dates!R[-2]C[11])"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues
    Range("C2").Select
    Dim Title
    Title = Sheets("Language").Cells(97, 3)
    ActiveCell.FormulaR1C1 = "=GetMonth(Dates!R[1]C[14]) &"", "" & GetYear(Dates!R[1]C[17]) & "" "" & """ & Title & """"
    Selection.Copy
'    Selection.PasteSpecial Paste:=xlValues
    'Hide columns for days that do not exist
    FixMonth NewName, Sheets("Dates").Cells(3, 17), Sheets("Dates").Cells(3, 20)
    Dim nTime
    Dim AddMon
    For r = 7 To 39
        If Len(Trim(Cells(r, 5).Value)) > 0 Then
            nTime = Cells(r, 4)
            If Sheets(NewName).Cells(r, 5).Value = "D" Or Sheets(NewName).Cells(r, 5).Value = "S" Then 'daily
                Sheets("Misc").Activate
                Sheets(NewName).Activate
                For c = 9 To 39
                    If Columns(c).ColumnWidth > 0 Then
                        If Sheets(NewName).Cells(r, 5).Value = "D" Then
                            Cells(r, c) = nTime
                        Else
                            Cells(r, c) = nTime * 3
                        End If
                    End If
                Next
            Else
                Dim nMo As Integer
                Dim nYr As Integer
                nMo = Sheets("Dates").Cells(3, 17)
                nYr = GetYear(Sheets("Dates").Cells(3, 20))
                Dim begdt As Date
                Dim enddt As Date
                '////////////////////////////////////////
'                begdt = CDate(nMo & "/1/" & nYr)
                'doesn't work with british dates
                '////////////////////////////////////////
                If IsDate(CStr(nMo) & "/31/" & CStr(nYr)) Then
                    enddt = CDate(CStr(nMo) & "/31/" & CStr(nYr))
                    begdt = enddt - 30
                Else
                    If IsDate(CStr(nMo) & "/30/" & CStr(nYr)) Then
                        enddt = CDate(nMo & "/30/" & nYr)
                        begdt = enddt - 29
                    Else
                        If IsDate(CStr(nMo) & "/29/" & CStr(nYr)) Then
                            enddt = CDate(CStr(nMo) & "/29/" & CStr(nYr))
                            begdt = enddt - 28
                        Else
                            If IsDate(CStr(nMo) & "/28/" & CStr(nYr)) Then
                                enddt = CDate(CStr(nMo) & "/28/" & CStr(nYr))
                                begdt = enddt - 27
                            End If
                        End If
                    End If
                End If
                If Sheets(NewName).Cells(r, 5).Value = "W" Then  'weekly
                    DoWeekly r, begdt, enddt, nMo, nYr, nTime
                ElseIf Sheets(NewName).Cells(r, 5).Value = "F" Then  'FortNightly
                    DoFortNightly r, begdt, enddt, nMo, nYr, nTime
                ElseIf Sheets(NewName).Cells(r, 5).Value = "M" Then  'Monthly
                    DoMonthly r, begdt, enddt, nMo, nYr, nTime, 0
                ElseIf Sheets(NewName).Cells(r, 5).Value = "T" Then  'Quarterly
                    AddMon = Sheets("Misc").Cells(22, 25) - 1
                    If nMo = (1 + AddMon) Or nMo = (4 + AddMon) Or nMo = (7 + AddMon) Or nMo = (10 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 1
                    End If
                ElseIf Sheets(NewName).Cells(r, 5).Value = "SA" Then  'Semi=Annually
                    AddMon = Sheets("Misc").Cells(23, 25) - 1
                    If nMo = (1 + AddMon) Or nMo = (7 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 2
                    End If
                ElseIf Sheets(NewName).Cells(r, 5).Value = "A" Then  'Annually
                    AddMon = Sheets("Misc").Cells(24, 25) - 1
                    If nMo = (1 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 3
                    End If
                End If
            End If
        End If
    Next
    '----------------------------------------------------------------------------------------
    'if week
    If Sheets("Dates").Cells(2, 22) = True Then
        Dim dDate
        Dim nDOM
        dDate = GetFirstDate(nMo, nYr, 1)
        If dDate + ((Sheets("Dates").Cells(3, 22) - 1) * 7) > enddt Then
            MsgBox "This is not a valid week for this month"
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(NewName).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Sheets("Input").Activate
            Exit Sub
        End If
        nDOM = Day(dDate)
        nDOM = nDOM + ((Sheets("Dates").Cells(3, 22) - 1) * 7)
        colray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM")
        
        Dim endcol
        endcol = 0
        If nDOM > 22 Then 'could overlap into the following month
            For i = 7 To 14
'                If Columns(i + nDOM).width = 0 Then
                If (Columns(i + nDOM).Hidden = True) Or (i + nDOM) = 40 Then
                    endcol = i - 1
                    Exit For
                End If
            Next
            If endcol = 0 Then
                GoTo RegProc
            End If
            
            Range(colray(7 + nDOM) & "6:" & colray((endcol - 1) + nDOM) & "39").Select
            Selection.Copy
            Range("I6").Select
            ActiveSheet.Paste
            'do the next months scehdule
            tmpsheet = CreateTempSchedule
            Range(colray(8) & "6:" & colray((13 - endcol) + 8) & "39").Select
            Selection.Copy
            Sheets(NewName).Activate
            Range(colray(endcol + 1) & "6").Select
            ActiveSheet.Paste
            'delete tmpsheet
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(tmpsheet).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            
'            Exit Sub
        Else
RegProc:
            Range(colray(7 + nDOM) & "6:" & colray(13 + nDOM) & "39").Select
            Selection.Copy
            Range("I6").Select
            ActiveSheet.Paste
        
        End If
        
        Range("P5:AO42").Select
        Selection.Clear
        Cells(6, 9) = "M" & Chr(10) & Cells(6, 9)
        Cells(6, 10) = "T" & Chr(10) & Cells(6, 10)
        Cells(6, 11) = "W" & Chr(10) & Cells(6, 11)
        Cells(6, 12) = "T" & Chr(10) & Cells(6, 12)
        Cells(6, 13) = "F" & Chr(10) & Cells(6, 13)
        Cells(6, 14) = "S" & Chr(10) & Cells(6, 14)
        Cells(6, 15) = "S" & Chr(10) & Cells(6, 15)
        Range("O5:O42").Select
        With Selection.Borders(xlRight)
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End If
    'end weekly
    '----------------------------------------------------------------------------------------
    
'    Range("A7:AM40").Select
'    Selection.Copy
'    Selection.PasteSpecial Paste:=xlValues
    'place pics
'    PutSchedPics NewName
    'cleanup numbers on sheet
'    Range("I7:AM39").Select
'    Selection.ClearContents
    
    'sort
    If Sheets("Dates").Cells(5, 22) = 1 Then 'run/stop
        Range("A7:AM39").Select
        Selection.Sort Key1:=Range("F7"), Order1:=xlDescending, Orientation:=xlTopToBottom
    ElseIf Sheets("Dates").Cells(5, 22) = 2 Then  'Frequency
        Range("A7:AN39").Select
        Selection.Sort Key1:=Range("AN7"), Order1:=xlAscending, Orientation:=xlTopToBottom
    End If
    
    'place pics
    PutSchedPics NewName
    
    'get rid of unecessary adjust buttons
    For i = 7 To 39
        If ActiveSheet.Cells(i, 41).Value = 0 Then
            ActiveSheet.DrawingObjects("AR" & CStr(i) & "LB").Select
            Selection.Delete
            ActiveSheet.DrawingObjects("AR" & CStr(i) & "RB").Select
            Selection.Delete
            ActiveSheet.DrawingObjects("AR" & CStr(i) & "LD").Select
            Selection.Delete
            ActiveSheet.DrawingObjects("AR" & CStr(i) & "RD").Select
            Selection.Delete
        Else
            If ActiveSheet.Cells(i, 5).Value = "D" Or ActiveSheet.Cells(i, 5).Value = "S" Then
                ActiveSheet.DrawingObjects("AR" & CStr(i) & "LB").Select
                Selection.Delete
                ActiveSheet.DrawingObjects("AR" & CStr(i) & "RB").Select
                Selection.Delete
                ActiveSheet.DrawingObjects("AR" & CStr(i) & "LD").Select
                Selection.Delete
                ActiveSheet.DrawingObjects("AR" & CStr(i) & "RD").Select
                Selection.Delete
            End If
        End If
    Next
    
    'Add buttons for weekly
    If Left(ActiveSheet.Name, 4) = "Week" Then
        Dim NewSheetName As String
        NewSheetName = ActiveSheet.Name
        Sheets("Misc").Visible = True
        ActiveSheet.Columns(16).ColumnWidth = 7.2
        ActiveSheet.Columns(18).ColumnWidth = 0
        ActiveSheet.Columns(19).ColumnWidth = 1.48
'        GoTo m1end
        For i = 7 To 39
            If (Cells(i, 9).Value > 0 Or Cells(i, 10).Value > 0 Or Cells(i, 11).Value > 0 Or _
               Cells(i, 12).Value > 0 Or Cells(i, 13).Value > 0 Or Cells(i, 14).Value > 0 Or _
               Cells(i, 15).Value > 0) And (Cells(i, 5) <> "S" And Cells(i, 5) <> "D") Then
                Sheets("Misc").Activate
                Range("AD" & CStr(i)).Select
                Selection.Copy
                Sheets(NewSheetName).Activate
                Range("P" & CStr(i)).Select
                ActiveSheet.Paste
            End If
        Next
        Sheets("Misc").Visible = False
    End If
    
    
'moved to put schedule pics
'    'Adjust heights
'    Dim ZeroRows As Integer
'    Dim ShiftlyRows As Integer
'    ZeroRows = 0
'    ShiftlyRows = 0
'    For i = 7 To 39
'        If ActiveSheet.Cells(i, 41).Value = "" Then
'            ZeroRows = ZeroRows + 1
'        ElseIf ActiveSheet.Cells(i, 5).Value = 0 Then
'            ShiftlyRows = ShiftlyRows + 1
'        End If
'    Next
    
    
    'cleanup
    Range("I5").Select
    Dim T As Long
    T = Len(Cells(5, 9))
    Range("C2").Select
        Cells(2, 3) = Right(Cells(5, 9), T - 6) + " Inspection Check Sheet"
    Range("A7").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True
    Application.ScreenUpdating = True
End Sub


Public Function GetFreqRank(str)
    If str = "S" Then
        GetFreqRank = 1
    ElseIf str = "D" Then
        GetFreqRank = 2
    ElseIf str = "W" Then
        GetFreqRank = 3
    ElseIf str = "F" Then
        GetFreqRank = 4
    ElseIf str = "M" Then
        GetFreqRank = 5
    ElseIf str = "T" Then
        GetFreqRank = 6
    ElseIf str = "SA" Then
        GetFreqRank = 7
    ElseIf str = "A" Then
        GetFreqRank = 8
    Else
        GetFreqRank = 9
    End If
End Function


Private Sub FixMonth(SheetName, mn, yr)
    Sheets(SheetName).Select
    If mn = 2 Then
        If yr = 2 Or yr = 6 Then
            Range("AL5:AM5").Select
            Selection.EntireColumn.Hidden = True
        Else
            Range("AK5:AM5").Select
            Selection.EntireColumn.Hidden = True
        End If
    End If
    If mn = 4 Or mn = 6 Or mn = 9 Or mn = 11 Then
        Range("AM5").Select
        Selection.EntireColumn.Hidden = True
    End If
End Sub


Private Sub DoWeekly(r, begdt, enddt, nMo, nYr, nTime)
    Dim nDOW As Integer 'day of week
    Dim dBOM As Date 'Beginning of Month
    nDOW = Sheets("Misc").Cells(3, 23)
    dBOM = GetFirstDate(nMo, nYr, nDOW)
    Dim tDate As Date
    Dim dates
    tDate = dBOM
    Do While tDate <= enddt
        If tDate >= begdt Then
            dates = AAdd(dates, tDate)
        End If
        tDate = tDate + 7
    Loop
    Dim nDOM As Integer 'day of month
    For i = 0 To UBound(dates)
        nDOM = Day(dates(i))
        Cells(r, 8 + nDOM) = nTime
    Next
End Sub


Private Sub DoFortNightly(r, begdt, enddt, nMo, nYr, nTime)
    Dim nDOW As Integer 'day of week
    Dim dBOY As Date 'Beginning of Year
    nDOW = Sheets("Misc").Cells(4, 23)
    dBOY = GetFirstDate(1, nYr, nDOW)
    If Sheets("Misc").Cells(20, 24).Value = 2 Then
        dBOY = dBOY + 7
    End If
    Dim tDate As Date
    Dim dates
    tDate = dBOY
    Do While tDate <= enddt
        If tDate >= begdt Then
            dates = AAdd(dates, tDate)
        End If
        tDate = tDate + 14
    Loop
    Dim nDOM As Integer 'day of month
    For i = 0 To UBound(dates)
        nDOM = Day(dates(i))
        Cells(r, 8 + nDOM) = nTime
    Next
End Sub


Private Sub DoMonthly(r, begdt, enddt, nMo, nYr, nTime, nRowMod)
    Dim nDOW As Integer 'day of week
    Dim dBOM As Date 'Beginning of Month
    Dim AddDays As Integer
    If nRowMod = 0 Then 'monthly
        AddDays = (Sheets("Misc").Cells(21, 24).Value - 1) * 7
    ElseIf nRowMod = 1 Then  'Quarterly
        AddDays = (Sheets("Misc").Cells(22, 24).Value - 1) * 7
    ElseIf nRowMod = 2 Then  'Semi-Annually
        AddDays = (Sheets("Misc").Cells(23, 24).Value - 1) * 7
    ElseIf nRowMod = 3 Then  'annually
        AddDays = (Sheets("Misc").Cells(24, 24).Value - 1) * 7
    End If
    nDOW = Sheets("Misc").Cells(5 + nRowMod, 23)
    dBOM = GetFirstDate(nMo, nYr, nDOW)
    Cells(r, 8 + Day(dBOM) + AddDays) = nTime
End Sub




Private Function GetFirstDate(nMo, nYr, nDOW)
    Dim StartRow As Integer
    If nYr = 1999 Then
        StartRow = 3
    ElseIf nYr = 2000 Then
        StartRow = 15
    ElseIf nYr = 2001 Then
        StartRow = 27
    ElseIf nYr = 2002 Then
        StartRow = 39
    ElseIf nYr = 2003 Then
        StartRow = 51
    ElseIf nYr = 2004 Then
        StartRow = 63
    ElseIf nYr = 2005 Then
        StartRow = 75
    ElseIf nYr = 2006 Then
        StartRow = 87
    ElseIf nYr = 2007 Then
        StartRow = 99
    ElseIf nYr = 2008 Then
        StartRow = 111
    ElseIf nYr = 2009 Then
        StartRow = 123
    ElseIf nYr = 2010 Then
        StartRow = 135
    ElseIf nYr = 2011 Then
        StartRow = 147
    ElseIf nYr = 2012 Then
        StartRow = 159
    ElseIf nYr = 2013 Then
        StartRow = 171
    ElseIf nYr = 2014 Then
        StartRow = 183
    ElseIf nYr = 2015 Then
        StartRow = 195
    ElseIf nYr = 2016 Then
        StartRow = 207
    ElseIf nYr = 2017 Then
        StartRow = 219
    ElseIf nYr = 2018 Then
        StartRow = 231
    ElseIf nYr = 2019 Then
        StartRow = 243
    ElseIf nYr = 2020 Then
        StartRow = 255
    End If
    GetFirstDate = Sheets("Dates").Cells(StartRow + (nMo - 1), 4 + nDOW)
End Function


Private Sub PutSchedPics(NewName)
    'Adjust heights added 1/8/00
'    Dim MTRows As Integer
    Dim ZeroRows As Integer
    Dim ShiftlyRows As Integer
'    MTRows = 0
    ZeroRows = 0
    ShiftlyRows = 0
    For i = 7 To 39
        If ActiveSheet.Cells(i, 5).Value = "" Then
            If ZeroRows < ShiftlyRows Then
                Rows(i).RowHeight = 0
                ZeroRows = ZeroRows + 1
            End If
        ElseIf ActiveSheet.Cells(i, 5).Value = "S" Then
            Sheets(NewName).Rows(i).RowHeight = 30
            ShiftlyRows = ShiftlyRows + 1
        ElseIf ActiveSheet.Cells(i, 41).Value = 0 Then
            Rows(i).RowHeight = 14.5
        Else
            Rows(i).RowHeight = 14.5
        End If
    Next
    
    
    For r = 7 To 39
        If Cells(r, 5) = "S" Then
            Sheets("Misc").Activate
'            Sheets("Misc").DrawingObjects("bmpShiftly").Select
            Sheets("Misc").DrawingObjects("DrawShiftly").Select
        Else
            Sheets("Misc").Activate
'            Sheets("Misc").DrawingObjects("bmpScheduled").Select
            Sheets("Misc").DrawingObjects("DrawScheduled").Select
        End If
        Selection.Copy
        Sheets(NewName).Activate
        For c = 9 To 39
            If Cells(r, c) > 0 Then
                ActiveSheet.Paste
                Selection.Left = ActiveSheet.Columns(c).Left + 1
                Selection.Top = ActiveSheet.Rows(r).Top + 1
                Selection.Height = ActiveSheet.Rows(r).RowHeight - 2
                Selection.Width = ActiveSheet.Columns(c).Width - 2
                Selection.Placement = xlMoveAndSize
                Selection.PrintObject = True
                Selection.Name = Selection.Name + "0" + CStr(r) + "0" + CStr(c)
            End If
         Next c
    Next r
End Sub


Public Sub SetDlgforSingleWeek()
    DialogSheets("dlgGetMonthYear").DialogFrame.Select
    If Sheets("Dates").Cells(2, 22) = False Then
        DialogSheets("dlgGetMonthYear").DialogFrame.Height = 115.5
    Else
        DialogSheets("dlgGetMonthYear").DialogFrame.Height = 147
        Sheets("Dates").Cells(3, 22) = 1
    End If
End Sub




Public Function CreateTempSchedule()
    Dim tmpName As String
    'check to make sure there is a time entered for each row used
    tmpName = "tmp " & Left(Trim(GetMonth(Sheets("Dates").Cells(3, 17))), 3) & ", " & GetYear(Sheets("Dates").Cells(3, 20))
    'if sheet already exists, delete it
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(tmpName).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets("ScheduleTemplate").Copy After:=Worksheets(Worksheets.Count)
    Sheets("ScheduleTemplate (2)").Visible = True
    Sheets("ScheduleTemplate (2)").Select
    Sheets("ScheduleTemplate (2)").Name = tmpName
    'Hide columns for days that do not exist
    If Sheets("Dates").Cells(3, 17) < 12 Then
        FixMonth tmpName, Sheets("Dates").Cells(3, 17) + 1, Sheets("Dates").Cells(3, 20)
    Else
        FixMonth tmpName, 1, Sheets("Dates").Cells(3, 20) + 1
    End If
    Dim nTime As Integer
    Dim AddMon As Integer
    For r = 7 To 39
        If Len(Trim(Cells(r, 5).Value)) > 0 Then
            nTime = Cells(r, 4)
            If Sheets(tmpName).Cells(r, 5).Value = "D" Or Sheets(tmpName).Cells(r, 5).Value = "S" Then 'daily
                Sheets("Misc").Activate
                Sheets(tmpName).Activate
                For c = 9 To 39
                    If Columns(c).ColumnWidth > 0 Then
                        If Sheets(tmpName).Cells(r, 5).Value = "D" Then
                            Cells(r, c) = nTime
                        Else
                            Cells(r, c) = nTime * 3
                        End If
                    End If
                Next
            Else
                Dim nMo As Integer
                Dim nYr As Integer
                nMo = Sheets("Dates").Cells(3, 17)
                If nMo < 12 Then
                    nMo = nMo + 1
                    nYr = GetYear(Sheets("Dates").Cells(3, 20))
                Else
                    nMo = 1
                    nYr = GetYear(Sheets("Dates").Cells(3, 20))
                    nYr = nYr + 1
                End If
                Dim begdt As Date
                Dim enddt As Date
                '////////////////////////////////////////
'                begdt = CDate(nMo & "/1/" & nYr)
                'doesn't work with british dates
                '////////////////////////////////////////
                If IsDate(CStr(nMo) & "/31/" & CStr(nYr)) Then
                    enddt = CDate(CStr(nMo) & "/31/" & CStr(nYr))
                    begdt = enddt - 30
                Else
                    If IsDate(CStr(nMo) & "/30/" & CStr(nYr)) Then
                        enddt = CDate(nMo & "/30/" & nYr)
                        begdt = enddt - 29
                    Else
                        If IsDate(CStr(nMo) & "/29/" & CStr(nYr)) Then
                            enddt = CDate(CStr(nMo) & "/29/" & CStr(nYr))
                            begdt = enddt - 28
                        Else
                            If IsDate(CStr(nMo) & "/28/" & CStr(nYr)) Then
                                enddt = CDate(CStr(nMo) & "/28/" & CStr(nYr))
                                begdt = enddt - 27
                            End If
                        End If
                    End If
                End If
                If Sheets(tmpName).Cells(r, 5).Value = "W" Then  'weekly
                    DoWeekly r, begdt, enddt, nMo, nYr, nTime
                ElseIf Sheets(tmpName).Cells(r, 5).Value = "F" Then  'FortNightly
                    DoFortNightly r, begdt, enddt, nMo, nYr, nTime
                ElseIf Sheets(tmpName).Cells(r, 5).Value = "M" Then  'Monthly
                    DoMonthly r, begdt, enddt, nMo, nYr, nTime, 0
                ElseIf Sheets(tmpName).Cells(r, 5).Value = "T" Then  'Quarterly
                    AddMon = Sheets("Misc").Cells(22, 25) - 1
                    If nMo = (1 + AddMon) Or nMo = (4 + AddMon) Or nMo = (7 = AddMon) Or nMo = (10 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 1
                    End If
                ElseIf Sheets(tmpName).Cells(r, 5).Value = "SA" Then  'Semi=Annually
                    AddMon = Sheets("Misc").Cells(23, 25) - 1
                    If nMo = (1 + AddMon) Or nMo = (7 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 2
                    End If
                ElseIf Sheets(tmpName).Cells(r, 5).Value = "A" Then  'Annually
                    AddMon = Sheets("Misc").Cells(24, 25) - 1
                    If nMo = (1 + AddMon) Then
                        DoMonthly r, begdt, enddt, nMo, nYr, nTime, 3
                    End If
                End If
            End If
        End If
    Next
    CreateTempSchedule = tmpName
End Function

Code errors out at this Line "If Len(Trim(Cells(r, 5).Value)) > 0 Then"

I apologize in advance... been awhile since I've played with codes. I know enough to sometimes save the day but the deep stuff can get me in trouble.

Eric
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
ohmedic88 said:
Goal... Is there a way that I can Lock the Workbook format to be macro enabled save only?
Click to expand...

No and there are no bullet proof ways to ensure macro security is enabled. The most common method I've seen (and used) is to have all pages except a macro warning sheet invisible by default.

Then include start up code that hides your warning and unhides all other sheets.

To preserve you'll also need "before close" event code to rehide all your sheets and unhide the warning page! Make sense?
 
Upvote 0
Actually that sounds great... Can you point me in a direction where I can view a sample code?

Eric

ScottR said:
No and there are no bullet proof ways to ensure macro security is enabled. The most common method I've seen (and used) is to have all pages except a macro warning sheet invisible by default.

Then include start up code that hides your warning and unhides all other sheets.

To preserve you'll also need "before close" event code to rehide all your sheets and unhide the warning page! Make sense?
Click to expand...
 
Upvote 0
Add these to the ThisWorkbook class module and change "Sheet1" to the name of your new warning sheet. A couple of notes

wbSave preserves the saved state of the workbook so it automatically resaves (if saved=true) to prevent reprompting the user when sheets are hidden.
The open code contains a "resume next" to account for an error created if Excel tries to make all sheets invisible, at any point during the code execution.

xlSheetVeryHidden (or 2 as it is known on the weekends) prevents users from unhiding the sheet without using VBA.

Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim WS As Worksheet, wbSave

wbSave = ThisWorkbook.Saved

For Each WS In ThisWorkbook.Sheets
    If WS.Name = "Sheet1" Then
        WS.Visible = xlSheetVisible
    Else
        WS.Visible = xlSheetVeryHidden
    End If
Next

If wbSave = True Then ThisWorkbook.Save

End Sub

Private Sub Workbook_Open()

On Error Resume Next

Dim WS As Worksheet, svSh As Worksheet
For Each WS In ThisWorkbook.Sheets
    If WS.Name <> "Sheet1" Then
        WS.Visible = xlSheetVisible
    Else
        Set svSh = WS
        WS.Visible = xlSheetVeryHidden
    End If
Next

svSh.Visible = xlSheetVeryHidden

End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
VBA to remove formulas with values causing wrong calculations
2
Replies
12
Views
268
Peter_SSs
Peter_SSs
R
  • Solved
SaveAs method not actually saving, wrong sheets being deleted (1004 Error)
Replies
4
Views
404
Alex Blakenburg
A
C
  • Question
Consolidation
Replies
0
Views
457
cccs16
C
A
  • Solved
Error with working days in a month
Replies
5
Views
248
Anthony47
A
S
  • Question
Autofilter in VBA when criteria is has more words separated by a comma in 2 sheets
Replies
0
Views
473
shafiey
S

Forum statistics

Threads
1,214,833
Messages
6,121,868
Members
449,053
Latest member
Mesh

Share this page

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
Back
Top