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

Delete Blanks in all rows or columns VBA

The following scripts will delete blank cells from rows / columns.

Option Explicit

'DeleteBlankRows will only delete a Row if it's completely empty
Sub DeleteBlankRows()
    Dim Rw As Long, RwCnt As Long, Rng As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error GoTo Exits:
    If Selection.Rows.Count > 1 Then
        Set Rng = Selection
    Else
        Set Rng = Range(Rows(1), Rows(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row()))
    End If
    RwCnt = 0
    For Rw = Rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(Rng.Rows(Rw).EntireRow) = 0 Then
            Rng.Rows(Rw).EntireRow.Delete
            RwCnt = RwCnt + 1
        End If
    Next Rw

Exits:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


'DeleteBlankColumns will only delete a Column if it's completely empty
Sub DeleteBlankColumns()
    Dim Col As Long, ColCnt As Long, Rng As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error GoTo Exits:
    If Selection.Columns.Count > 1 Then
        Set Rng = Selection
    Else
        Set Rng = Range(Columns(1), Columns(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column()))
    End If
    ColCnt = 0
    For Col = Rng.Columns.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(Rng.Columns(Col).EntireColumn) = 0 Then
            Rng.Columns(Col).EntireColumn.Delete
            ColCnt = ColCnt + 1
        End If
    Next Col

Exits:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

'RemoveRow will delete an entire row IF there is a Blank/empty cell within A Column

Private Sub RemoveRow()

    On Error Resume Next    ' In case there are no blanks

    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Ping IP Addresses on Worksheet (without disturbing other cells)

I have created a script where i needed to ping IP Addresses on a Worksheet and have not only the results of the ping, but also the mac-address of the end device if possible and all without disturbing (overwriting or deleting) other columns / rows.

It might not be up to the correct standards but it works for me and i wanted to save it here for future reference.

The script can be added to a single module.

'AKA known as QuickPing

Sub WorksheetPing()

Dim MySheet As Worksheet

Dim strColumn

Dim intRow

Dim strComputer

Dim strMACAddress

Dim cell As Range

Dim rNa As Range

Dim FindIt As String

Dim strAddy As String

Dim strColumn1

Set MySheet = Application.ActiveSheet

YesNo = MsgBox("Shall i PING all addresses?", vbYesNo + vbInformation, "PING all addresses on Sheet?")

Select Case YesNo

Case vbYes

On Error GoTo Errormessage

 'Ask which column the IP or Hostname resides

strColumn = InputBox("Which letter column do you want to ping?", "Machines column")

Columns(strColumn).Offset(0, 1).Select

Selection.Insert Shift:=xlToRight

'Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")

strColumn1 = Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")

Range("A1").Activate

'Ping the IP Addresses

For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row

Cells(intRow, Asc(UCase(strColumn)) - 63).Value = GetPingInfo(Cells(intRow, strColumn).Value)

Next

Case vbNo

Exit Sub

End Select

YesNo = MsgBox("Do you want the Mac-Addresses?", vbYesNo + vbInformation, "Mac-Addresses can be obtained")

Select Case YesNo

Case vbYes

Application.ScreenUpdating = False

'Change Failures to Red Font and then move them over temporarily

On Error Resume Next

FindIt = "Failure"

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

rNa.Font.ColorIndex = 3

rNa.Offset(0, -1).Copy

rNa.Offset(0, 0).PasteSpecial xlPasteValuesAndNumberFormats

rNa.Offset(0, -1).clear

Set rNa = ActiveSheet.UsedRange.FindNext(rNa)

Loop While rNa.Address <> strAddy

End If

'Get the Mac-Address

Columns(strColumn).Offset(0, 2).Select

Selection.Insert Shift:=xlToRight

Range("A1").Select

For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row

Cells(intRow, Asc(UCase(strColumn)) - 62).Value = Get_MAC_Address(Cells(intRow, strColumn).Value)

Next

'For Each Cell In Range(Whichever Column was chosen)

   Columns(strColumn1).Select

   For Each cell In Selection

   If cell.Font.ColorIndex = 3 Then

   cell.Copy

   cell.Offset(0, -1).PasteSpecial xlPasteValuesAndNumberFormats

   cell.Value = "Failure"

   cell.Font.ColorIndex = 1

   cell.Offset(1, 0).Activate

   End If

   Next

'Fit all columns

Cells.EntireColumn.AutoFit

Range("A1").Activate

'Deselect the last cell and hide the Display Status Bar

Application.CutCopyMode = False

Application.StatusBar = ""

Application.DisplayStatusBar = False

Application.ScreenUpdating = True

Case vbNo

End Select

Errormessage:

End Sub

Function GetPingInfo(strComputer)

Dim objShell, boolCode

Set objShell = CreateObject("WScript.Shell")

boolCode = objShell.Run("Ping -n 1 -w 300 " & strComputer, 0, True)

   If boolCode = 0 Then

GetPingInfo = "Successful Reply"

Else

GetPingInfo = "Failure"

End If

End Function

Function Get_MAC_Address(strComputer)

Set objShell = CreateObject("WScript.Shell")

Set objFSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

objFSO.DeleteFile "c:\MAC.txt", True

On Error GoTo 0

Application.DisplayStatusBar = True

Application.StatusBar = "Getting MAC for " & strComputer & "..."

DoEvents

objShell.Run "cmd /c NBTSTAT -a " & strComputer & " | FIND ""MAC Address"" > C:\MAC.txt", 0, True

Set objMACFile = objFSO.OpenTextFile("C:\MAC.txt", 1, False)

While Not objMACFile.AtEndOfStream

strLine = objMACFile.ReadLine

If Len(strLine) > 35 Then

strMAC = Mid(strLine, 19, 17)

End If

Wend

objMACFile.Close

Set objMACFile = Nothing

Set objShell = Nothing

Set objFSO = Nothing

Get_MAC_Address = strMAC

End Function

Create Table of Contents VBA

This script will create a Table of Contents, documenting every worksheet in the active workbook and putting the results into a table (of contents).

Option Explicit

Sub CreateTOC()

    Dim ws As Worksheet

    Dim nmToc As Name

    Dim rng1 As Range

    Dim lngProceed As Boolean

    Dim bNonWkSht As Boolean

    Dim lngSht As Long

    Dim lngShtNum As Long

    Dim strWScode As String

    Dim vbCodeMod

    'Test for an ActiveWorkbook to summarise

    If ActiveWorkbook Is Nothing Then

        MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"

        Exit Sub

    End If

    'Turn off updates, alerts and events

    With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

        .EnableEvents = False

    End With

    'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed

    On Error Resume Next

    Set nmToc = ActiveWorkbook.Names("TOC_Index")

    If Not nmToc Is Nothing Then

        lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")

        If lngProceed = vbYes Then

            Exit Sub

        Else

            ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete

        End If

    End If

    Set ws = ActiveWorkbook.Sheets.Add

    ws.Move before:=Sheets(1)

    'Add the marker range name

    ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]

    ws.Name = "TOC_Index"

    On Error GoTo 0

    On Error GoTo ErrHandler

    For lngSht = 2 To ActiveWorkbook.Sheets.Count

        'set to start at A6 of TOC sheet

        'Test sheets to determine whether they are normal worksheets

        ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))

        If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then

            'Add hyperlinks to normal worksheets

            ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name

        Else

            'Add name of any non-worksheets

            ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name

            'Colour these sheets yellow

            ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow

            ws.Cells(lngSht + 4, 2).Font.Italic = True

            bNonWkSht = True

        End If

    Next lngSht

    'Add headers and formatting

    With ws

        With .[a1:a4]

            .Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))

            .Font.Size = 14

            .Cells(1).Font.Bold = True

        End With

        With .[a6].Resize(lngSht - 1, 1)

            .Font.Bold = True

            .Font.ColorIndex = 41

            .Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft

            .Columns("A:B").EntireColumn.AutoFit

        End With

    End With

    'Add warnings and macro code if there are non WorkSheet types present

    If bNonWkSht Then

        With ws.[A5]

            .Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"

            .Font.ColorIndex = 3

            .Font.Italic = True

        End With

        strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _

                    & "     Dim rng1 As Range" & vbCrLf _

                    & "     Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _

                    & "     If rng1 Is Nothing Then Exit Sub" & vbCrLf _

                    & "     On Error Resume Next" & vbCrLf _

                    & "     If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _

                    & "     If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _

                    & "End Sub" & vbCrLf

        Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)

        vbCodeMod.CodeModule.AddFromString strWScode

    End If

    'tidy up Application settings

    With Application

        .ScreenUpdating = True

        .DisplayAlerts = True

        .EnableEvents = True

    End With

ErrHandler:

    If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"

End Sub

Export Excel Worksheet to Text File

The following code will export a worksheet into a text file.
The script can create a file (and folder if necessary) on the fly.

Create module and paste the following script:


' This exports a sheet or range to a text file, using a
' user-defined separator character.
Public Sub ExportToTextFile(FName As String, _
    Sep As String, SelectionOnly As Boolean, _
    AppendData As Boolean)

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
    With Selection
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
Else
    With ActiveSheet.UsedRange
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
End If

If AppendData = True Then
    Open FName For Append Access Write As #FNum
Else
    Open FName For Output Access Write As #FNum
End If

For RowNdx = StartRow To EndRow
    WholeLine = ""
    For ColNdx = StartCol To EndCol
        If Cells(RowNdx, ColNdx).Value = "" Then
            CellValue = Chr(34) & Chr(34)
        Else
           CellValue = Cells(RowNdx, ColNdx).Value
        End If
        WholeLine = WholeLine & CellValue & Sep
    Next ColNdx
    WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
    Print #FNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub

'This is the script you run to get it to work

Sub DoTheExport()
Dim fso
Dim fol As String
'Change location as necessary
fol = "C:\"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
    fso.CreateFolder (fol)
Else
    MsgBox fol & " already exists!", vbExclamation, "Folder Exists"
End If

'The Export folder needs to match the folder location above.
'The ; in Sep:=";" defines the seperator character. Change this to suit
    ExportToTextFile FName:="C:\Test.txt", Sep:=";", _
       SelectionOnly:=False, AppendData:=True
End Sub