Adding and removing References to other Workbooks / Addins


Sub AddReference()

     Dim Reference As Object

     On Error GoTo ErrMsg
     With ThisWorkbook.VBProject
           For Each Reference In .References
                 If Reference.Description Like "SyslogReports" Then Exit Sub
           Next
           .References.AddFromFile "C:\Documents and Settings\dtayl211\Application Data\Microsoft\AddIns\Syslog Reports.xla"
           '.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 22, 0
     End With
     Exit Sub

ErrMsg:
     MsgBox "Object Library Not Registered on this machine"
End Sub


Sub RemoveSpecifiedReference()
' This example removes 'PowerPoint' reference
' from ThisWorkbook.VBProject .
' Instead of 'ThisWorkbook' you can work with ActiveWorkbook.
'--
Dim ref As Variant
Dim i As Integer
'--
With ThisWorkbook.VBProject
For i = .References.Count To 1 Step -1
Set ref = .References(i)
If Not ref.BuiltIn Then
'MsgBox ref.Name
' Customize Reference name

If ref.Name = "SyslogReports" Then
MsgBox ref.Name
' uncomment the following code line
.References.Remove ref
End If
End If
Next i
End With
End Sub

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