Unprotecting a protected Workbook

I don't advocate it, but this is a script to break the password on a password protected Excel workbook

Sub UnprotectWorkBook()
'Break the Password on a Protected Excel Workbook
    Dim funnet As Boolean: Dim tekst As String
    Dim i As Integer: Dim j As Integer: Dim k As Integer: Dim l As Integer
    Dim m As Integer: Dim N As Integer: Dim o As Integer: Dim p As Integer
    Dim gmlStatusLinje As Variant: Dim gmlTid As Variant
    Dim oldCalculation As Integer
    On Error Resume Next

    funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
    oldCalculation = Application.Calculation
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    gmlStatusLinje = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    gmlTid = Now()
    Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")

    ActiveWorkbook.Unprotect
    funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)

    If Not funnet Then
   For i = lower To upper
  tekst = Chr(i)
  ActiveWorkbook.Unprotect    '(tekst)
  funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
  If funnet Then Exit For
   Next
   Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
   If Not funnet Then
  For i = lower1 To lower2
 For j = lower To upper
tekst = Chr(i) + Chr(j)
ActiveWorkbook.Unprotect (tekst)
funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
  Next
   End If
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2
 For k = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k)
ActiveWorkbook.Unprotect (tekst)
funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2
For l = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l)
 ActiveWorkbook.Unprotect (tekst)
 funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
 If funnet Then Exit For
Next
Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2
 For m = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m)
 ActiveWorkbook.Unprotect (tekst)
 funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
 If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2: For m = lower1 To lower2
 For N = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N)
ActiveWorkbook.Unprotect (tekst)
funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2: For m = lower1 To lower2: For N = lower1 To lower2
For o = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o)
 ActiveWorkbook.Unprotect (tekst)
 funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
 If funnet Then Exit For
Next
Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
If funnet Then Exit For
 Next
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2
 For m = lower1 To lower2: For N = lower1 To lower2: For o = lower1 To lower2
 For p = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o) + Chr(p)
ActiveWorkbook.Unprotect (tekst)
funnet = Not (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    Application.ScreenUpdating = True
    Call MsgBox(tekstBook & " Time: " & Format(Now() - gmlTid, "hh.mm.ss") & Chr(13) & Chr(13) & "The Protection on the Workbook should now be broken." & Chr(13) & "Check Tools > Protection > Protect Workbook" & Chr(13) & "to ensure the protection has been removed." & Chr(13) & Chr(13), vbOKOnly + vbInformation, progName)
    Application.StatusBar = False
    Application.DisplayStatusBar = gmlStatusLinje
    Application.Calculation = oldCalculation
End Sub

Unprotecting a protected Worksheet

I don't advocate it, but this is a script to break the password on a password protected Excel worksheet.


'Break the Password on a locked Worksheet
Sub UnprotectSheet()
'Break Protection on a Worksheet.
    Dim funnet As Boolean: Dim tekst As String
    Dim i As Integer: Dim j As Integer: Dim k As Integer
    Dim l As Integer: Dim m As Integer: Dim N As Integer: Dim o As Integer: Dim p As Integer
    Dim gmlStatusLinje As Variant: Dim gmlTid As Variant
    Dim oldCalculation As Integer
    On Error Resume Next

    oldCalculation = Application.Calculation
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    gmlStatusLinje = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    gmlTid = Now()
    Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
    ActiveSheet.Protect ("")
    funnet = ActiveSheet.Unprotect("")

    If Not funnet Then
   For i = lower To upper
  tekst = Chr(i)
  funnet = ActiveSheet.Unprotect(tekst)
  If funnet Then Exit For
   Next
    End If
    Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
    If Not funnet Then
   For i = lower1 To lower2
  For j = lower To upper
 tekst = Chr(i) + Chr(j)
 funnet = ActiveSheet.Unprotect(tekst)
 If funnet Then Exit For
  Next
  Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2
 For k = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k)
funnet = ActiveSheet.Unprotect(tekst)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2
For l = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l)
 funnet = ActiveSheet.Unprotect(tekst)
 If funnet Then Exit For
Next
Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2
 For m = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m)
 funnet = ActiveSheet.Unprotect(tekst)
 If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2: For m = lower1 To lower2
 For N = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N)
funnet = ActiveSheet.Unprotect(tekst)
If funnet Then Exit For
 Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
   For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2: For m = lower1 To lower2: For N = lower1 To lower2
For o = lower To upper
 tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o)
 funnet = ActiveSheet.Unprotect(tekst)
 If funnet Then Exit For
Next
Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
If funnet Then Exit For
 Next
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    If Not funnet Then
For i = lower1 To lower2: For j = lower1 To lower2: For k = lower1 To lower2: For l = lower1 To lower2
For m = lower1 To lower2: For N = lower1 To lower2: For o = lower1 To lower2
For p = lower To upper
tekst = Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr(N) + Chr(o) + Chr(p)
funnet = ActiveSheet.Unprotect(tekst)
If funnet Then Exit For
Next
 Application.StatusBar = Format(Now() - gmlTid, "hh.mm.ss")
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
 Next
 If funnet Then Exit For
Next
If funnet Then Exit For
 Next
 If funnet Then Exit For
  Next
  If funnet Then Exit For
   Next
    End If
    Application.ScreenUpdating = True
MsgBox "Password broken"
    Application.StatusBar = False
    Application.DisplayStatusBar = gmlStatusLinje
    Application.Calculation = oldCalculation
End Sub

Organise Your Worksheets into Alphabetical order

'Organise Your Worksheets!
Sub Sort_Sheets()
    On Error GoTo 0
    Dim Sort_Mode_Descending As Boolean
    Dim No_of_Sheets As Integer
    Dim Outer_Loop As Integer
    Dim Inner_Loop As Integer
    No_of_Sheets = Sheets.Count
    'Change Flag As appropriate
    Sort_Mode_Descending = False
    For Outer_Loop = 1 To No_of_Sheets
        For Inner_Loop = 1 To Outer_Loop
            If Sort_Mode_Descending = True Then
                If UCase(Sheets(Outer_Loop).Name) > UCase(Sheets(Inner_Loop).Name) Then
                    Sheets(Outer_Loop).Move Before:=Sheets(Inner_Loop)
                End If
            End If
            If Sort_Mode_Descending = False Then
                If UCase(Sheets(Outer_Loop).Name) < UCase(Sheets(Inner_Loop).Name) Then
                    Sheets(Outer_Loop).Move Before:=Sheets(Inner_Loop)
                End If
            End If
        Next Inner_Loop
    Next Outer_Loop
End Sub

Formatting all specific text into italics / removing italics

'Convert all specified text on Worksheet into italic font
Sub ItalicFont()
    Dim rNa As Range
    Dim FindIt As String
    Dim strAddy As String
  'Application box so the specific word is entered and searched for
    Prompt = "What is the value you want to apply the bold font to?"
    Title = "Search Value Input"
    FindIt = InputBox(Prompt, Title)    Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

    If Not rNa Is Nothing Then
        strAddy = rNa.Address
        Do
            'make the specific word bold
            rNa.Font.Italic = True
            ' add any other formatting required here
            Set rNa = ActiveSheet.UsedRange.FindNext(rNa)
        Loop While rNa.Address <> strAddy
    End If
End Sub

'Convert all specified text on Worksheet into non-italic font
Sub RemoveItalicFont()
    Dim rNa As Range
    Dim FindIt As String
    Dim strAddy As String
   'Application box so the specific word is entered and searched for
    Prompt = "What is the value you want to apply the bold font to?"
    Title = "Search Value Input"
    Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

    If Not rNa Is Nothing Then
        strAddy = rNa.Address
        Do
            'make the specific word bold
            rNa.Font.Italic = False
            ' add any other formatting required here
            Set rNa = ActiveSheet.UsedRange.FindNext(rNa)
        Loop While rNa.Address <> strAddy
    End If
End Sub

Formatting all specific text into bold / removing bold

'Convert all specified text on Worksheet into bold font
Sub BoldFont()
    Dim rNa As Range
    Dim FindIt As String
    Dim strAddy As String
    'Application box so the specific word is entered and searched for
    Prompt = "What is the value you want to apply the bold font to?"
    Title = "Search Value Input"
    FindIt = InputBox(Prompt, Title)
    Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

    If Not rNa Is Nothing Then
        strAddy = rNa.Address
        Do
            'make the specific word bold
            rNa.Font.Bold = True
            ' add any other formatting required here
            Set rNa = ActiveSheet.UsedRange.FindNext(rNa)
        Loop While rNa.Address <> strAddy
    End If
End Sub

'Convert all specified text on Worksheet into non-bold font

Sub RemoveBoldFont()

    Dim rNa As Range

    Dim FindIt As String

    Dim strAddy As String

    'Application box so the specific word is entered and searched for

    Prompt = "What is the value you want to remove the bold font from?"

    Title = "Search Value Input"

    FindIt = InputBox(Prompt, Title)

    Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _

                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

    If Not rNa Is Nothing Then

        strAddy = rNa.Address

        Do

            'make the specific word bold

            rNa.Font.Bold = False

            ' add any other formatting required here

            Set rNa = ActiveSheet.UsedRange.FindNext(rNa)

        Loop While rNa.Address <> strAddy

    End If

End Sub

Restoring Columns/Rows & Auto-fitting on all Worksheets

'Restore Column and Row Width / Height to Standard
Sub Height_Width()
    On Error Resume Next
    ActiveSheet.Cells.RowHeight = 15.00
    ActiveSheet.Cells.ColumnWidth = 8.43
End Sub

'AutoFit All Columns on ALL Worksheets
Private Sub AutoFitAllColumns()
    Application.ScreenUpdating = False
    Dim wkSt As String
    Dim wkBk As Worksheet
    wkSt = ActiveSheet.Name
    For Each wkBk In ActiveWorkbook.Worksheets
        On Error Resume Next
        wkBk.Activate
        Cells.EntireColumn.AutoFit
    Next wkBk
    Sheets(wkSt).Select
    Application.ScreenUpdating = True
End Sub

Unhide Rows and Columns

'Unhide All Rows on Worksheet
Sub Unhide_All_Rows()
    On Error Resume Next
    'in case the sheet is protected
    ActiveSheet.Cells.EntireRow.Hidden = False
End Sub

'Unhide All Columns on Worksheet
Sub Unhide_All_Columns()
    On Error Resume Next
    'in case the sheet is protected
    ActiveSheet.Cells.EntireColumn.Hidden = False
End Sub

Adding New Rows

'Add a new row every other row
Private Sub AddNewRows()
    Application.ScreenUpdating = False
    Range("A1").Select
    ActiveSheet.UsedRange.Select
    r = Selection.Rows.Count
    For i = 1 To r
        Rows(i * 2).Insert Shift:=xlDown
    Next i
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub



'Add a new row after a specific word in Column A and repeat on that word.
Sub AddRowForm()
    Dim iLoop As Integer
    Dim rNa As Range
    Dim i As Integer
    Dim FindIt As String
    Dim Prompt As String
    Dim Title As String

    Prompt = "What is the original value you want to replace? (Note this only works on Column A)"
    Title = "Search Value Input"
    FindIt = InputBox(Prompt, Title)
    On Error Resume Next
    iLoop = WorksheetFunction.CountIf(Columns(1), FindIt)
    Set rNa = Range("A1")
    For i = 1 To iLoop
        Set rNa = Columns(1).Find(What:=FindIt, After:=rNa, LookIn:=xlValues, LookAt:=xlWhole, _
                                  SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
        rNa.EntireRow.Offset(1, 0).Insert
    Next i
End Sub