Posts by benjamint

Private Sub Workbook_BeforeClose _(Cancel As Boolean)




Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String




    QuestionToMessageBox = "Are you sure you want to CLOSE and SAVE the template?"




    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Go back to template")




    If YesOrNoAnswerToMessageBox = vbNo Then
    Range("A1").Select
    Workbooks("Template.XLSM").Close Savechanges:=False
Else
Call Copy_ActiveSheet
Workbooks("Template.XLSM").Close Savechanges:=False
End If
End Sub

Sub Copy_ActiveSheet(Optional x As Boolean)Application.ScreenUpdating = False
'Working in Excel 2000-2010
    Dim fname As Variant
    Dim NewWb As Workbook
    Dim FileFormatValue As Long
    'Check the Excel version
    If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then




        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:="", _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")




        If fname <> False Then
            'Copy the ActiveSheet to new workbook
    Dim myArray() As Variant
    Dim i As Integer
    Dim j As Integer
    j = 0
    For i = 1 To Sheets.Count
        If Sheets(i).Visible = True Then
            ReDim Preserve myArray(j)
            myArray(j) = i
            j = j + 1
        End If
    Next i
    Sheets(myArray).Select
    Sheets(myArray).COPY
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True
Call Unhide_K_P
If ActiveSheet.Index = Worksheets.Count Then
Worksheets(1).Select
Else
ActiveSheet.Next.Select
End If
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
Call Unhide_K_P
If ActiveSheet.Index = Worksheets.Count Then
Worksheets(1).Select
Else
ActiveSheet.Next.Select
End If
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True
Call Unhide_K_P
            Set NewWb = ActiveWorkbook




            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            Set NewWb = Nothing




        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
        " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
        " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
        " Excel 2000-2003 Workbook (*.xls), *.xls," & _
        " Excel Binary Workbook (*.xlsb), *.xlsb", _
        FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")




        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
            End Select




            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
    j = 0
    For i = 1 To Sheets.Count
        If Sheets(i).Visible = True Then
            ReDim Preserve myArray(j)
            myArray(j) = i
            j = j + 1
        End If
    Next i
                Sheets(myArray).Select
                Sheets(myArray).COPY
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True
Call Unhide_K_P
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
Call Unhide_K_P
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
ActiveSheet.Unprotect Password:="testing"
ActiveSheet.Shapes.SelectAll
Selection.Delete
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True
Call Unhide_K_P
                Set NewWb = ActiveWorkbook




                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                Set NewWb = Nothing




            End If
        End If
    End If
Application.ScreenUpdating = True
End Sub

Sub Macro3()
'
' Macro3 Macro
'
 
 
'
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    If ws.Visible = xlSheetVisible Then
        ws.Select
ActiveSheet.Select
ActiveSheet.COPY
ActiveSheet.Protect Password:="testing", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True
    End If
Next ws
End Sub

Private Sub ComboBox1_Change()Dim strRange As String
    If ComboBox1.ListIndex > -1 Then
       strRange = ComboBox1
       Label2.Caption = strRange
       strRange = Replace(strRange, " ", "_")
            With ComboBox2
                .RowSource = vbNullString
                .RowSource = strRange
                .ListIndex = 0
            End With




    Else
       Label2.Caption = "Project subtype:"
   End If
End Sub