My collection of sample macros

• Copy those macros.
• Open Visual basic
• Find a module in a workbook you would like to post it to
• Paste it there.

Macros from the internet do not have to all the time. These are tested and work for my computer

1 Convert all formulas on the sheet to values

Sub ToValues()
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub

Source: TrumpExcel.com

2 Unhide all hidden sheets

Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

Source: ExcelChamps.com

3 Protect or unprotect all sheets with a password

Sub ProtectAll()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Password:", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:=ps
Next ws
End Sub

This one is for unprotecting it

Sub Unprotect all()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Password:", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect Password:=ps
Next ws
End Sub

Source: ExcelChamps.com

4 Order sheets alphabetically

Sub Alphabetically()
Application.ScreenUpdating = False
Dim ShCount As Integer, i As Integer, j As Integer
ShCount = Sheets.Count
For i = 1 To ShCount - 1
For j = i + 1 To ShCount
If Sheets(j).Name < Sheets(i).Name Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

Source: TrumpExcel.com

5 Unhide all hidden rows and columns

Sub UnhideRowsColumns()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

Source: ExcelChamps.com

6 Create a backup copy of a file you would like to enter

Saves a backup of the file into the same folder

Watch out: Does not work with documents stored on OneDrive or SharePoint

Sub Backup()
ActiveWorkbook.SaveCopyAs Filename:=ActiveWorkbook.Path & _
"\" & Format(Now, "yyyy-mm-dd hh-mm-ss") & " " & _
ActiveWorkbook.name
End Sub

7 Send the current document via email

7a Simple version if you do not use Outlook

If you do not use Outlook, try this simpler version that uses default email client:

Sub OpenWorkbookAsAttachment()
Application.Dialogs(xlDialogSendMail).Show
End Sub

Source: ExcelChamps.com

7b Advanced version for Outlook only

If you have outlook, use this version. You can edit the message text and other

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "excel@jiribenedikt.com"
.Subject = "Report KPIs"
.Body = "Dear team, I am sending a last month's report."
.Attachments.Add ActiveWorkbook.FullName
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

You can add a carbon copy (cc) by including a line between .to and .subject:

.cc = „adam@jiribenedikt.com;bara@jiribenedikt.com“ .bcc = „cyril@jiribenedikt.com“

.cc = "adam@jiribenedikt.com;bara@jiribenedikt.com"
.bcc = "cyril@jiribenedikt.com"

If you replace

.display

with

.send

The email will get sent right away without the preview.

Source: ExcelChamps.com

8 A message that pops up when you open or close the workbook

Sub auto_open()
MsgBox "Hello. This is my amazing spreadsheet. Find other amazing sheets at www.jiribenedikt.com"
End Sub

Sub auto_close()
MsgBox "Thanks for using the sheet, do not hesitate to contact the author at jiri@jiribenedikt.com"
End Sub

Source: ExcelChamps.com

9 Automatically create a table of contents

Sub TableOfContents()
Dim i As Long
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Obsah").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Activeworkbook.Sheets.Add Before:=ActiveWorkbook.Worksheets(1)
ActiveSheet.Name = "Obsah"
For i = 1 To Sheets.Count
With ActiveSheet
.Hyperlinks.Add _
Anchor:=ActiveSheet.Cells(i, 1), _
Address:="", _
SubAddress:="'" & Sheets(i).Name & "'!A1", _
ScreenTip:=Sheets(i).Name, _
TextToDisplay:=Sheets(i).Name
End With
Next i
End Sub

Source: ExcelChamps.com

10 Delete all empty rows

Sub DeleteEmptyRows()
    Dim LastRowIndex As Integer
    Dim RowIndex As Integer
    Dim UsedRng As Range
 
    Set UsedRng = ActiveSheet.UsedRange
    LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
    Application.ScreenUpdating = False
 
    For RowIndex = LastRowIndex To 1 Step -1
        If Application.CountA(Rows(RowIndex)) = 0 Then
            Rows(RowIndex).Delete
        End If
    Next RowIndex
 
    Application.ScreenUpdating = True
End Sub

Source: Ablebits.com

11 Split to multiple sheets based on one column

Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

Source: Extendoffice.com

12 Save each sheet as an individual document

Sub SaveEachSheet()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ActiveWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

Source: Extendoffice.com

13 Save sheets as individual PDFs

Sub SaveSheetsAsPDF()
 
Dim ws As Worksheet
 
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & " PDF " & DateString
MkDir FolderName

For Each ws In Worksheets
ws.Select
nm = ws.Name
 
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=FolderName & "\" & nm & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
 
Next ws
 
End Sub

14 Remove special characters

This is a custom Excel function made to remove Czech special characters. You simply use by putting =NOSPECIAL(text) into a cell. Cannot be placed into personal macro workbook!

Function NOSPECIAL(thestring As String)
Dim A As String * 1
Dim B As String * 1
Dim i As Integer

Const AccChars = "áäčďéěíĺľňóôőöŕšťúůűüýřžÁÄČĎÉĚÍĹĽŇÓÔŐÖŔŠŤÚŮŰÜÝŘŽ"
Const RegChars = "aacdeeillnoooorstuuuuyrzAACDEEILLNOOOORSTUUUUYRZ"

For i = 1 To Len(AccChars)
    A = Mid(AccChars, i, 1)
    B = Mid(RegChars, i, 1)
    thestring = Replace(thestring, A, B)
Next

NOSPECIAL = thestring
End Function

Source: Miroslavpecka.cz

Tips for VBA programming

Find a last row of an active worksheet and store it into lastrow variable:

lastrow = ActiveSheet.UsedRange.Rows.Count

Cycle trough all rows in a worksheet:

'find the last row:
lastrow = ActiveSheet.UsedRange.Rows.Count

'which column to cycle trough? Use numbers
column = 1

for row = 1 to lastrow

' here comes watherever you want to do for each row. For example, you can display it as messagebox:

msgbox(cells(row,column).value)
next