Excel VBA Macro Codes: Ready-to-Use Examples

Automatically adds a sequential list of numbers downward from the active cell. An input box asks how many numbers to insert.

Sub AddSerialNumbers()
    Dim i As Integer
    On Error GoTo Last
    i = InputBox("Enter Value", "Enter Serial Numbers")
    For i = 1 To i
        ActiveCell.Value = i
        ActiveCell.Offset(1, 0).Activate
    Next i
Last: Exit Sub
End Sub

Inserts a specified number of columns to the right of the active cell in one step — no need to repeat the insert command manually.

Sub InsertMultipleColumns()
    Dim i As Integer, j As Integer
    ActiveCell.EntireColumn.Select
    On Error GoTo Last
    i = InputBox("Enter number of columns to insert", "Insert Columns")
    For j = 1 To i
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightorAbove
    Next j
Last: Exit Sub
End Sub

Inserts multiple rows at once starting from the active cell. Enter the count in the input box when prompted.

Sub InsertMultipleRows()
    Dim i As Integer, j As Integer
    ActiveCell.EntireRow.Select
    On Error GoTo Last
    i = InputBox("Enter number of rows to insert", "Insert Rows")
    For j = 1 To i
        Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove
    Next j
Last: Exit Sub
End Sub

Instantly auto-fits the width of every column in the active worksheet to match its content — no manual dragging needed.

Sub AutoFitColumns()
    Cells.Select
    Cells.EntireColumn.AutoFit
End Sub

Instantly auto-fits the height of every row in the active worksheet to match its content.

Sub AutoFitRows()
    Cells.Select
    Cells.EntireRow.AutoFit
End Sub

Removes text wrap from every cell in the active worksheet, then auto-fits all rows and columns so your layout snaps back into shape.

Sub RemoveTextWrap()
    Cells.WrapText = False
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
End Sub

Unmerges all merged cells in the current selection. Add to your Quick Access Toolbar for one-click access.

Sub UnmergeCells()
    Selection.UnMerge
End Sub

Makes all hidden rows and columns in the active worksheet visible again — no need to unhide them one by one.

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

Copies the selected range and pastes it as a static picture into the same sheet. Useful for locking down a table's appearance for reporting.

Sub PasteAsPicture()
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Pictures.Paste.Select
End Sub

Pastes the selected range as a linked image — the picture updates automatically when the source data changes. Great for dashboards.

Sub LinkedPicture()
    Selection.Copy
    ActiveSheet.Pictures.Paste(Link:=True).Select
End Sub

Checks each cell in the selection and highlights any duplicate values in yellow. Select your range before running.

Sub HighlightDuplicateValues()
    Dim myRange As Range, myCell As Range
    Set myRange = Selection
    For Each myCell In myRange
        If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
            myCell.Interior.ColorIndex = 36
        End If
    Next myCell
End Sub

Double-click any cell to select its entire row and column — great for navigating large data tables. This goes in the sheet's own code window, not a module.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim strRange As String
    strRange = Target.Cells.Address & "," & _
               Target.Cells.EntireColumn.Address & "," & _
               Target.Cells.EntireRow.Address
    Range(strRange).Select
End Sub

Select a range and run this macro to highlight the top 10 values in green using a conditional formatting rule.

Sub HighlightTopTen()
    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Top
        .Rank = 10
        .Percent = False
    End With
    With Selection.FormatConditions(1).Interior
        .Color = 13561798
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Highlights all named ranges in the workbook so you can see exactly which cells have names assigned to them.

Sub HighlightNamedRanges()
    Dim RangeName As Name, HighlightRange As Range
    On Error Resume Next
    For Each RangeName In ActiveWorkbook.Names
        Set HighlightRange = RangeName.RefersToRange
        HighlightRange.Interior.ColorIndex = 36
    Next RangeName
End Sub

Prompts for a threshold and highlights all cells in the selection that are greater than it in green.

Sub HighlightGreaterThanValues()
    Dim i As Integer
    i = InputBox("Enter Greater Than Value", "Enter Value")
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=i
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .Font.Color = RGB(0, 0, 0)
        .Interior.Color = RGB(31, 218, 154)
    End With
End Sub

Prompts for a threshold and highlights all cells in the selection that are below it in red.

Sub HighlightLowerThanValues()
    Dim i As Integer
    i = InputBox("Enter Lower Than Value", "Enter Value")
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:=i
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .Font.Color = RGB(0, 0, 0)
        .Interior.Color = RGB(217, 83, 79)
    End With
End Sub

Scans every cell in the selection and changes the font colour of any negative number to red.

Sub HighlightNegativeNumbers()
    Dim Rng As Range
    For Each Rng In Selection
        If WorksheetFunction.IsNumber(Rng) Then
            If Rng.Value < 0 Then
                Rng.Font.Color = -16776961
            End If
        End If
    Next
End Sub

Searches for a specific text string and highlights matching characters in red. Select two columns before running: column A = source text, column B = the text to find.

Sub HighlightSpecificText()
    Dim myStr As String, myRg As Range
    Dim I As Long, J As Long
    On Error Resume Next
    Set myRg = Application.InputBox("Select a two-column range:", "Selection Required", , , , , , 8)
    If myRg Is Nothing Then Exit Sub
    If myRg.Columns.Count <> 2 Then
        MsgBox "Please select exactly two columns." : Exit Sub
    End If
    For I = 0 To myRg.Rows.Count - 1
        myStr = myRg.Range("B1").Offset(I, 0).Value
        With myRg.Range("A1").Offset(I, 0)
            .Font.ColorIndex = 1
            For J = 1 To Len(.Text)
                If Mid(.Text, J, Len(myStr)) = myStr Then
                    .Characters(J, Len(myStr)).Font.ColorIndex = 3
                End If
            Next J
        End With
    Next I
End Sub

Applies the built-in "Note" style to all cells containing comments in the current selection, making them easy to spot at a glance.

Sub HighlightCommentCells()
    Selection.SpecialCells(xlCellTypeComments).Select
    Selection.Style = "Note"
End Sub

Highlights every other row in the selection to create a striped/banded table effect that makes data easier to read.

Sub HighlightAlternateRows()
    Dim rng As Range
    For Each rng In Selection.Rows
        If rng.Row Mod 2 = 1 Then
            rng.Style = "20% - Accent1"
        End If
    Next rng
End Sub

Scans the entire used range and applies the "Bad" style to any cell containing a spelling error.

Sub HighlightMisspelledCells()
    Dim rng As Range
    For Each rng In ActiveSheet.UsedRange
        If Not Application.CheckSpelling(Word:=rng.Text) Then
            rng.Style = "Bad"
        End If
    Next rng
End Sub

Scans the entire worksheet, highlights all error cells in red, and shows a count of how many were found.

Sub HighlightErrors()
    Dim rng As Range, i As Integer
    For Each rng In ActiveSheet.UsedRange
        If WorksheetFunction.IsError(rng) Then
            i = i + 1
            rng.Style = "Bad"
        End If
    Next rng
    MsgBox "There are total " & i & " error(s) in this worksheet."
End Sub

Prompts for a value, then highlights every matching cell in the used range and shows a count of matches found.

Sub HighlightSpecificValues()
    Dim rng As Range, i As Integer, c As Variant
    c = InputBox("Enter Value To Highlight")
    For Each rng In ActiveSheet.UsedRange
        If rng = c Then
            rng.Style = "Note"
            i = i + 1
        End If
    Next rng
    MsgBox "There are total " & i & " " & c & " in this worksheet."
End Sub

Finds cells that look blank but contain a single space character — a common data quality issue — and highlights them.

Sub HighlightBlankWithSpace()
    Dim rng As Range
    For Each rng In ActiveSheet.UsedRange
        If rng.Value = " " Then
            rng.Style = "Note"
        End If
    Next rng
End Sub

Finds the highest value in the selected range and highlights it in green.

Sub HighlightMaxValue()
    Dim rng As Range
    For Each rng In Selection
        If rng = WorksheetFunction.Max(Selection) Then
            rng.Style = "Good"
        End If
    Next rng
End Sub

Finds the lowest value in the selected range and highlights it in green.

Sub HighlightMinValue()
    Dim rng As Range
    For Each rng In Selection
        If rng = WorksheetFunction.Min(Selection) Then
            rng.Style = "Good"
        End If
    Next rng
End Sub

Highlights all cells in the selection that contain a unique (non-duplicate) value using a conditional formatting rule.

Sub HighlightUniqueValues()
    Dim rng As Range
    Set rng = Selection
    rng.FormatConditions.Delete
    Dim uv As UniqueValues
    Set uv = rng.FormatConditions.AddUniqueValues
    uv.DupeUnique = xlUnique
    uv.Interior.Color = vbGreen
End Sub

Highlights cells where the value differs from the corresponding cell in the reference column — ideal for comparing two data sets side by side.

Sub ColumnDifference()
    Selection.ColumnDifferences(ActiveCell).Select
    Selection.Style = "Bad"
End Sub

Highlights cells where the value differs from the corresponding cell in the reference row.

Sub RowDifference()
    Selection.RowDifferences(ActiveCell).Select
    Selection.Style = "Bad"
End Sub

Protects only formula cells, leaving all other cells editable. Useful for sharing workbooks where you want to prevent accidental formula deletion.

Sub LockCellsWithFormulas()
    With ActiveSheet
        .Unprotect
        .Cells.Locked = False
        .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
        .Protect AllowDeletingRows:=True
    End With
End Sub

Scans the entire used range and highlights every cell containing a formula in yellow — useful for quickly auditing a sheet.

Sub HighlightFormulas()
    Dim cell As Range
    For Each cell In ActiveSheet.UsedRange
        If cell.HasFormula Then
            cell.Interior.Color = RGB(255, 255, 0)
        End If
    Next cell
End Sub

Converts all text in the selected cells to UPPER CASE. Non-text cells are left unchanged.

Sub ConvertToUpperCase()
    Dim Rng As Range
    For Each Rng In Selection
        If Application.WorksheetFunction.IsText(Rng) Then
            Rng.Value = UCase(Rng)
        End If
    Next
End Sub

Converts all text in the selected cells to lower case. Non-text cells are skipped.

Sub ConvertToLowerCase()
    Dim Rng As Range
    For Each Rng In Selection
        If Application.WorksheetFunction.IsText(Rng) Then
            Rng.Value = LCase(Rng)
        End If
    Next
End Sub

Capitalises The First Letter Of Every Word. Useful for cleaning name lists or titles.

Sub ConvertToProperCase()
    Dim Rng As Range
    For Each Rng In Selection
        If WorksheetFunction.IsText(Rng) Then
            Rng.Value = WorksheetFunction.Proper(Rng.Value)
        End If
    Next
End Sub

Capitalises only the first letter of the text in each cell. Perfect for sentence-style labels and descriptions.

Sub ConvertToSentenceCase()
    Dim Rng As Range
    For Each Rng In Selection
        If WorksheetFunction.IsText(Rng) Then
            Rng.Value = UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng) - 1))
        End If
    Next Rng
End Sub

Trims leading, trailing, and extra internal spaces from every text cell in the selection — equivalent to applying Excel's TRIM function directly to the values.

Sub RemoveSpaces()
    Dim myCell As Range
    Select Case MsgBox("You Can't Undo This. Save Workbook First?", vbYesNoCancel, "Alert")
        Case Is = vbYes:    ThisWorkbook.Save
        Case Is = vbCancel: Exit Sub
    End Select
    For Each myCell In Selection
        If Not IsEmpty(myCell) Then myCell = Trim(myCell)
    Next myCell
End Sub

A custom worksheet function that removes a specified number of characters from the start of a text string. Use it in a cell like a regular formula.

Public Function RemoveFirstC(rng As String, cnt As Long)
    RemoveFirstC = Right(rng, Len(rng) - cnt)
End Function

Prompts you to enter a character and removes every instance of it from all cells in the selection.

Sub RemoveChar()
    Dim Rng As Range, rc As String
    rc = InputBox("Character(s) to Remove", "Enter Value")
    For Each Rng In Selection
        Selection.Replace What:=rc, Replacement:=""
    Next
End Sub

A custom worksheet function that reverses the characters in a text string. Use it directly in cells like any Excel formula.

Public Function Rvrse(ByVal cell As Range) As String
    Rvrse = VBA.StrReverse(cell.Value)
End Function

Counts every word across all cells in the active worksheet and displays the total in a message box.

Sub WordCountWorksheet()
    Dim WordCnt As Long, rng As Range
    Dim S As String, N As Long
    For Each rng In ActiveSheet.UsedRange.Cells
        S = Application.WorksheetFunction.Trim(rng.Text)
        N = 0
        If S <> vbNullString Then
            N = Len(S) - Len(Replace(S, " ", "")) + 1
        End If
        WordCnt = WordCnt + N
    Next rng
    MsgBox "There are total " & Format(WordCnt, "#,##0") & " words in the active worksheet"
End Sub

A custom worksheet function that converts any whole number to its written English equivalent. Use it in cells like a regular Excel formula: =NumberToWords(A1).

Function NumberToWords(ByVal MyNumber As Long) As String
    Dim Units(1 To 9) As String, Teens(10 To 19) As String
    Dim Tens(2 To 9) As String, Result As String
    Units(1)="One":Units(2)="Two":Units(3)="Three":Units(4)="Four"
    Units(5)="Five":Units(6)="Six":Units(7)="Seven"
    Units(8)="Eight":Units(9)="Nine"
    Teens(10)="Ten":Teens(11)="Eleven":Teens(12)="Twelve"
    Teens(13)="Thirteen":Teens(14)="Fourteen":Teens(15)="Fifteen"
    Teens(16)="Sixteen":Teens(17)="Seventeen"
    Teens(18)="Eighteen":Teens(19)="Nineteen"
    Tens(2)="Twenty":Tens(3)="Thirty":Tens(4)="Forty"
    Tens(5)="Fifty":Tens(6)="Sixty":Tens(7)="Seventy"
    Tens(8)="Eighty":Tens(9)="Ninety"
    If MyNumber = 0 Then NumberToWords = "Zero": Exit Function
    If MyNumber < 0 Then Result = "Negative ": MyNumber = Abs(MyNumber)
    If MyNumber >= 1000 Then
        Result = Result & Units(Int(MyNumber/1000)) & " Thousand "
        MyNumber = MyNumber Mod 1000
    End If
    If MyNumber >= 100 Then
        Result = Result & Units(Int(MyNumber/100)) & " Hundred "
        MyNumber = MyNumber Mod 100
    End If
    If MyNumber >= 20 Then
        Result = Result & Tens(Int(MyNumber/10)) & " "
        MyNumber = MyNumber Mod 10
    ElseIf MyNumber >= 10 Then
        Result = Result & Teens(MyNumber): MyNumber = 0
    End If
    If MyNumber > 0 Then Result = Result & Units(MyNumber)
    NumberToWords = Trim(Result)
End Function

Multiplies every number in the selection by a value you specify. The original code used addition (+) instead of multiplication (*) — now fixed. Also upgraded to Double so decimal multipliers like 1.5 work correctly.

Sub MultiplyAllValues()
    Dim rng As Range, i As Double
    i = InputBox("Enter the number to multiply by", "Multiply Values")
    If i = 0 Then Exit Sub
    For Each rng In Selection
        If WorksheetFunction.IsNumber(rng) Then
            rng.Value = rng.Value * i
        End If
    Next rng
End Sub

Adds the same number to every cell in the selection. Enter a negative value (e.g. -10) to subtract from all values instead. Useful for bulk adjustments like adding a fixed fee or offset across a list of prices.

Sub AddToAllValues()
    Dim rng As Range, i As Double
    i = InputBox("Enter the number to add", "Add to Values")
    For Each rng In Selection
        If WorksheetFunction.IsNumber(rng) Then
            rng.Value = rng.Value + i
        End If
    Next rng
End Sub

Replaces every number in the selection with its square root, in-place — no helper column needed. Useful for bulk statistical transformations on a dataset.

Sub GetSquareRoot()
    Dim rng As Range
    For Each rng In Selection
        If WorksheetFunction.IsNumber(rng) Then
            rng.Value = Sqr(rng)
        End If
    Next rng
End Sub

Replaces every number in the selection with its cube root. Uses the exponent ^ (1/3) since VBA has no built-in cube root function.

Sub GetCubeRoot()
    Dim rng As Range
    For Each rng In Selection
        If WorksheetFunction.IsNumber(rng) Then
            rng.Value = rng ^ (1 / 3)
        End If
    Next rng
End Sub

Strips the decimal portion from every number in the selection, rounding down to the nearest whole number using VBA's Int() function.

Sub RemoveDecimals()
    Dim rng As Range
    For Each rng In Selection
        rng.Value = Int(rng)
        rng.NumberFormat = "0"
    Next rng
End Sub

Converts all negative numbers in the selection to their absolute (positive) values using VBA's Abs() function. Non-numeric cells are skipped.

Sub RemoveNegativeSign()
    Dim rng As Range
    For Each rng In Selection
        If WorksheetFunction.IsNumber(rng) Then
            rng.Value = Abs(rng)
        End If
    Next rng
End Sub

Removes leading apostrophes from numbers stored as text — a common problem when importing data from other systems. The apostrophe forces Excel to treat the number as text; this macro converts them back to true numeric values.

Sub RemoveApostrophes()
    Selection.Value = Selection.Value
End Sub

Finds every empty cell (including cells with a single space) in the selection and fills it with 0. Prevents #DIV/0! and other formula errors that occur when calculations reference blank cells.

Sub ReplaceBlankWithZero()
    Dim rng As Range
    For Each rng In Selection
        If rng = "" Or rng = " " Then
            rng.Value = "0"
        End If
    Next rng
End Sub

Converts Roman numeral text (e.g. XIV, XLII) in selected cells to their Arabic number equivalents using Excel's built-in ARABIC worksheet function.

Sub ConvertRomanToArabic()
    Dim rng As Range
    For Each rng In Selection
        If Not WorksheetFunction.IsNonText(rng) Then
            rng.Value = WorksheetFunction.Arabic(rng)
        End If
    Next rng
End Sub

Appends a degree symbol (°) to every number in the selection. Useful for temperature data, angles, or any measurement that requires the degree symbol but where you want to keep the values editable.

Sub AddDegreeSymbol()
    Dim rng As Range
    For Each rng In Selection
        If IsNumeric(rng.Value) Then
            rng.Value = rng.Value & "°"
        End If
    Next
End Sub

Replaces every formula in the selection with its current calculated value — permanently locking in results and removing formula dependencies. A save prompt appears first because this action cannot be undone.

Sub ConvertToValues()
    Dim MyRange As Range, MyCell As Range
    Select Case MsgBox("You Can't Undo This. Save Workbook First?", vbYesNoCancel, "Alert")
        Case Is = vbYes:    ThisWorkbook.Save
        Case Is = vbCancel: Exit Sub
    End Select
    Set MyRange = Selection
    For Each MyCell In MyRange
        If MyCell.HasFormula Then
            MyCell.Formula = MyCell.Value
        End If
    Next MyCell
End Sub

Extracts the day number from each date in the selection and replaces the date with just the day (e.g. 25-Dec-2024 becomes 25). Useful for grouping or filtering data by day of month.

Sub DateToDay()
    Dim tempCell As Range
    For Each tempCell In Selection
        If IsDate(tempCell) = True Then
            With tempCell
                .Value = Day(tempCell)
                .NumberFormat = "0"
            End With
        End If
    Next tempCell
End Sub

Extracts just the year from each date in the selection (e.g. 25-Dec-2024 becomes 2024). Useful for year-based grouping in reports or pivot tables.

Sub DateToYear()
    Dim tempCell As Range
    For Each tempCell In Selection
        If IsDate(tempCell) = True Then
            With tempCell
                .Value = Year(tempCell)
                .NumberFormat = "0"
            End With
        End If
    Next tempCell
End Sub

Strips the time portion from cells that contain a combined date and time value, leaving just the date. Uses VBA.Int() to drop the decimal (time) part of the serial number.

Sub RemoveTime()
    Dim Rng As Range
    For Each Rng In Selection
        If IsDate(Rng) = True Then
            Rng.Value = VBA.Int(Rng.Value)
        End If
    Next
    Selection.NumberFormat = "dd-mmm-yy"
End Sub

Strips the date from combined date-time cells, returning only the time value. Uses VBA.Fix() to subtract the integer (date) part and keep just the decimal (time) portion.

Sub RemoveDate()
    Dim Rng As Range
    For Each Rng In Selection
        If IsDate(Rng) = True Then
            Rng.Value = Rng.Value - VBA.Fix(Rng.Value)
        End If
    Next
    Selection.NumberFormat = "hh:mm:ss am/pm"
End Sub

Inserts a full 24-hour time sequence (1:00 AM through 12:00 AM) starting from the active cell, one hour per row going downward. Useful for building time-based schedules or logs.

Sub InsertTimeRange()
    Dim i As Integer
    For i = 1 To 24
        ActiveCell.FormulaR1C1 = i & ":00"
        ActiveCell.NumberFormat = "[$-409]h:mm AM/PM;@"
        ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
    Next i
End Sub

Inserts the full alphabet (A–Z or a–z) starting from the active cell, one letter per row. Two versions provided — uppercase and lowercase. Uses ASCII character codes with Chr().

' Uppercase A-Z
Sub InsertUppercaseAlphabets()
    Dim i As Integer
    For i = 65 To 90
        ActiveCell.Value = Chr(i)
        ActiveCell.Offset(1, 0).Select
    Next i
End Sub

' Lowercase a-z
Sub InsertLowercaseAlphabets()
    Dim i As Integer
    For i = 97 To 122
        ActiveCell.Value = Chr(i)
        ActiveCell.Offset(1, 0).Select
    Next i
End Sub

Toggles between Excel's A1 (column letters + row numbers) and R1C1 (row and column numbers) reference styles without going into Excel Options. Run the matching Sub for the style you want.

' Switch to R1C1 style
Sub ActivateR1C1()
    Application.ReferenceStyle = xlR1C1
End Sub

' Switch back to A1 style
Sub ActivateA1()
    Application.ReferenceStyle = xlA1
End Sub

A combined toggle macro — checks the current reference style and switches to the other one automatically. Run once to switch to R1C1, run again to switch back to A1.

Sub ToggleReferenceStyle()
    If Application.ReferenceStyle = xlA1 Then
        Application.ReferenceStyle = xlR1C1
        MsgBox "Switched to R1C1 reference style.", vbInformation
    Else
        Application.ReferenceStyle = xlA1
        MsgBox "Switched to A1 reference style.", vbInformation
    End If
End Sub

Adds multiple new worksheets after the active sheet in one step. Enter the count when prompted.

Sub InsertMultipleSheets()
    Dim i As Integer
    i = InputBox("Enter number of sheets to insert.", "Insert Multiple Sheets")
    Sheets.Add After:=ActiveSheet, Count:=i
End Sub

Hides every worksheet in the workbook except the one you're currently viewing.

Sub HideAllButActiveSheet()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
            ws.Visible = xlSheetHidden
        End If
    Next ws
End Sub

Makes all hidden sheets in the workbook visible again with a single click.

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

Permanently deletes every worksheet except the currently active one. Cannot be undone — save first.

Sub DeleteAllButActiveSheet()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws
End Sub

Scans every sheet in the workbook and deletes any that are completely empty.

Sub DeleteBlankWorksheets()
    Dim Ws As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Application.Worksheets
        If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
            Ws.Delete
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Protects the active worksheet with a password. Edit the password directly in the code before running.

Sub ProtectWorksheet()
    ActiveSheet.Protect "mypassword", True, True
End Sub

Removes protection from the active worksheet using the password set in the code.

Sub UnprotectWorksheet()
    ActiveSheet.Unprotect "mypassword"
End Sub

Prompts for a password and applies it to every worksheet in the workbook simultaneously.

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

Password-protects every sheet in the workbook at once. An input box lets you set the password on the fly — no need to hardcode it.

Sub ProtectAllSheets()
    Dim ws As Worksheet, pwd As String
    pwd = InputBox("Enter a password to protect all sheets", "Protect Sheets")
    If pwd = "" Then Exit Sub
    For Each ws In ThisWorkbook.Sheets
        ws.Protect Password:=pwd
    Next ws
    MsgBox "All sheets are now protected.", vbInformation
End Sub

Removes password protection from every sheet in the workbook at once.

Sub UnprotectAllSheets()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        ws.Unprotect Password:="password"
    Next ws
End Sub

Sorts all worksheets alphabetically. A message box lets you choose ascending or descending order.

Sub SortWorksheets()
    Dim i As Integer, j As Integer, iAnswer As VbMsgBoxResult
    iAnswer = MsgBox("Sort Ascending? Click No for Descending.", vbYesNoCancel + vbQuestion, "Sort Worksheets")
    For i = 1 To Sheets.Count
        For j = 1 To Sheets.Count - 1
            If iAnswer = vbYes Then
                If UCase$(Sheets(j).Name) > UCase$(Sheets(j+1).Name) Then
                    Sheets(j).Move After:=Sheets(j+1)
                End If
            ElseIf iAnswer = vbNo Then
                If UCase$(Sheets(j).Name) < UCase$(Sheets(j+1).Name) Then
                    Sheets(j).Move After:=Sheets(j+1)
                End If
            End If
        Next j
    Next i
End Sub

Creates a new "Table of Content" sheet with a clickable hyperlink to every other sheet in the workbook — essential for large multi-sheet files.

Sub TableOfContent()
    Dim i As Long
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Table of Content").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)
    ActiveSheet.Name = "Table of Content"
    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

Exports every worksheet in the workbook as its own PDF file. Update the folder path in the code before running.

Sub SaveEachSheetAsPDF()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.ExportAsFixedFormat xlTypePDF, "C:\YourFolder\" & ws.Name & ".pdf"
    Next ws
End Sub

Inserts 2 blank rows after every existing row — useful for adding spacing in reports or room for annotations.

Sub InsertRowsBetweenRows()
    Dim i As Long
    For i = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count To 1 Step -1
        ThisWorkbook.Sheets("Sheet1").Rows(i + 1).Resize(2).Insert
    Next i
End Sub

Turns off the page break display on all worksheets across all open workbooks — cleans up the view after printing.

Sub DisablePageBreaks()
    Dim wb As Workbook, Sht As Worksheet
    Application.ScreenUpdating = False
    For Each wb In Application.Workbooks
        For Each Sht In wb.Worksheets
            Sht.DisplayPageBreaks = False
        Next Sht
    Next wb
    Application.ScreenUpdating = True
End Sub

Sorts data in a defined range by the first column in ascending order. Update the sheet name and range to match your data.

Sub AutoSortData()
    With ThisWorkbook.Sheets("Sheet1").Range("A1:D100")
        .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
    End With
End Sub

Saves a copy of the current workbook in the same folder with today's date appended to the filename.

Sub CreateBackup()
    ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
        "\" & Format(Date, "mm-dd-yy") & " " & ThisWorkbook.Name
End Sub

Saves a backup with both date and time in the filename so multiple daily saves don't overwrite each other.

Sub SaveTimestampedBackup()
    Dim backupPath As String
    backupPath = "C:\Backup\MyWorkbook_" & Format(Now(), "yyyymmdd_hhmmss") & ".xlsm"
    ThisWorkbook.SaveCopyAs backupPath
End Sub

Closes every open workbook and prompts you to save any with unsaved changes.

Sub CloseAllWorkbooks()
    Dim wbs As Workbook
    For Each wbs In Workbooks
        wbs.Close SaveChanges:=True
    Next wbs
End Sub

Copies the active worksheet into a brand new workbook — useful for sharing a single sheet without exposing the rest of the file.

Sub CopySheetToNewWorkbook()
    ThisWorkbook.ActiveSheet.Copy _
        Before:=Workbooks.Add.Worksheets(1)
End Sub

Opens a file picker to select multiple Excel files, then moves all their sheets into the current workbook. Hold Ctrl to select multiple files.

Sub CombineWorkbooks()
    Dim FilesToOpen As Variant, x As Integer
    FilesToOpen = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Files (*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm", _
        MultiSelect:=True, Title:="Select Files to Combine")
    If TypeName(FilesToOpen) = "Boolean" Then Exit Sub
    Application.ScreenUpdating = False
    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        ActiveWorkbook.Sheets.Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend
    Application.ScreenUpdating = True
    MsgBox "Done! All sheets combined.", vbInformation
End Sub

Saves each worksheet as its own .xlsx file in a specified folder. Update the path before running.

Sub ExportSheetsToWorkbooks()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        ActiveWorkbook.SaveAs "C:\ExportedSheets\" & ws.Name & ".xlsx"
        ActiveWorkbook.Close False
    Next ws
End Sub

Checks all open workbooks and displays a count of how many have unsaved changes.

Sub CountUnsavedWorkbooks()
    Dim book As Workbook, i As Integer
    For Each book In Workbooks
        If book.Saved = False Then i = i + 1
    Next book
    MsgBox i & " workbook(s) have unsaved changes."
End Sub

Closes the workbook automatically after 10 minutes of inactivity without saving. Useful for shared or sensitive files.

Sub AutoCloseAfterInactivity()
    Dim countDown As Date
    countDown = Now + TimeValue("00:10:00")
    Do Until Now >= countDown
        If Not Application.Interactive Then Exit Sub
        DoEvents
    Loop
    ThisWorkbook.Close SaveChanges:=False
End Sub

Creates a new folder on your computer from within Excel. Checks first whether the folder already exists to avoid errors.

Sub CreateDirectory()
    Dim path As String
    path = "C:\NewFolder"
    If Not Dir(path, vbDirectory) <> "" Then
        MkDir path
        MsgBox "Folder created: " & path
    Else
        MsgBox "Folder already exists."
    End If
End Sub

Displays a message box every time the workbook is opened. The macro must be named exactly Auto_Open to trigger automatically.

Sub Auto_Open()
    MsgBox "Welcome! Thanks for opening this file."
End Sub

Displays a message box when the workbook is closed. Must be named exactly Auto_Close to trigger automatically.

Sub Auto_Close()
    MsgBox "Goodbye! Don't forget to check excelchamps.com for more tips."
End Sub

Exports the selected range to a named PDF file saved in your default Excel folder. Enter a filename when prompted.

Sub SaveSelectionAsPDF()
    Dim pdfPath As String, fileName As String
    fileName = InputBox("Enter a name for the PDF file", "Save as PDF", "MySelection")
    If fileName = "" Then Exit Sub
    pdfPath = Application.DefaultFilePath & "\" & fileName & ".pdf"
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
    MsgBox "PDF saved to: " & pdfPath, vbInformation
End Sub

Prints only the selected range without touching any print area settings.

Sub PrintSelection()
    Selection.PrintOut Copies:=1, Collate:=True
End Sub

Prompts for a start and end page number, then prints only that range of pages.

Sub PrintCustomPages()
    Dim startpage As Integer, endpage As Integer
    startpage = InputBox("Enter Start Page number.", "Enter Value")
    If Not WorksheetFunction.IsNumber(startpage) Then
        MsgBox "Invalid Start Page number." : Exit Sub
    End If
    endpage = InputBox("Enter End Page number.", "Enter Value")
    If Not WorksheetFunction.IsNumber(endpage) Then
        MsgBox "Invalid End Page number." : Exit Sub
    End If
    Selection.PrintOut From:=startpage, To:=endpage, Copies:=1, Collate:=True
End Sub

Sets narrow margins and immediately prints one copy — no manual margin configuration required.

Sub PrintNarrowMargin()
    With ActiveSheet.PageSetup
        .LeftMargin   = Application.InchesToPoints(0.25)
        .RightMargin  = Application.InchesToPoints(0.25)
        .TopMargin    = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

Opens every Excel file in a specified folder, prints one copy, then closes it. Update the folder path before running.

Sub PrintAllWorkbooksInFolder()
    Dim folderPath As String, filename As String
    folderPath = "C:\MyFolder\"
    filename = Dir(folderPath & "*.xls*")
    Do While filename <> ""
        Workbooks.Open Filename:=folderPath & filename
        ActiveWorkbook.PrintOut Copies:=1
        ActiveWorkbook.Close False
        filename = Dir()
    Loop
End Sub

Refreshes every pivot table across all worksheets in the workbook. The original only looped through the active sheet — now fixed to loop all sheets.

Sub RefreshAllPivots()
    Dim ws As Worksheet, pt As PivotTable
    For Each ws In ActiveWorkbook.Worksheets
        For Each pt In ws.PivotTables
            pt.RefreshTable
        Next pt
    Next ws
End Sub

Removes subtotals from all fields in the pivot table where your cursor is placed. Click inside the pivot table first, then run.

Sub HidePivotSubtotals()
    Dim pt As PivotTable, pf As PivotField
    On Error Resume Next
    Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    If pt Is Nothing Then
        MsgBox "Place your cursor inside a PivotTable first." : Exit Sub
    End If
    For Each pf In pt.PivotFields
        pf.Subtotals(1) = True
        pf.Subtotals(1) = False
    Next pf
End Sub

Dynamically updates the source data range of a pivot table to include new rows and columns. Update the sheet names and pivot table name before running.

Sub UpdatePivotTableRange()
    Dim Data_Sheet As Worksheet, Pivot_Sheet As Worksheet
    Dim StartPoint As Range, DataRange As Range
    Dim PivotName As String, NewRange As String
    Dim LastCol As Long, DownCell As Long
    Set Data_Sheet  = ThisWorkbook.Worksheets("PivotData")
    Set Pivot_Sheet = ThisWorkbook.Worksheets("Pivot")
    PivotName = "PivotTable1"
    Data_Sheet.Activate
    Set StartPoint = Data_Sheet.Range("A1")
    LastCol  = StartPoint.End(xlToRight).Column
    DownCell = StartPoint.End(xlDown).Row
    Set DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))
    NewRange = Data_Sheet.Name & "!" & DataRange.Address(ReferenceStyle:=xlR1C1)
    Pivot_Sheet.PivotTables(PivotName).ChangePivotCache _
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)
    Pivot_Sheet.PivotTables(PivotName).RefreshTable
    Pivot_Sheet.Activate
    MsgBox "Pivot Table range updated successfully."
End Sub

Toggles the GetPivotData function on or off without going into Excel Options.

Sub EnableGetPivotData()
    Application.GenerateGetPivotData = True
End Sub

Sub DisableGetPivotData()
    Application.GenerateGetPivotData = False
End Sub

Changes the selected chart to a clustered column chart. Click the chart first, then run. Change the constant to switch to other chart types.

Sub ChangeChartType()
    ActiveChart.ChartType = xlColumnClustered
End Sub

Converts the selected chart into a static picture pasted into cell A1 — useful for reports that should not change dynamically.

Sub ConvertChartToPicture()
    ActiveChart.ChartArea.Copy
    ActiveSheet.Range("A1").Select
    ActiveSheet.Pictures.Paste.Select
End Sub

Prompts for a title and adds it above the selected chart. Click the chart first, then run the macro.

Sub AddChartTitle()
    Dim i As Variant
    i = InputBox("Please enter your chart title", "Chart Title")
    On Error GoTo Last
    ActiveChart.SetElement (msoElementChartTitleAboveChart)
    ActiveChart.ChartTitle.Text = i
Last: Exit Sub
End Sub

Sets every chart in the active worksheet to the same width and height — great for consistent dashboard layouts.

Sub ResizeAllCharts()
    Dim i As Integer
    For i = 1 To ActiveSheet.ChartObjects.Count
        With ActiveSheet.ChartObjects(i)
            .Width  = 300
            .Height = 200
        End With
    Next i
End Sub

Removes every chart object from the active worksheet in a single run.

Sub DeleteAllCharts()
    Dim cht As ChartObject
    For Each cht In ActiveSheet.ChartObjects
        cht.Delete
    Next cht
End Sub

Opens an Outlook email with the current workbook already attached. Uses .Display to let you preview before sending — change to .Send to send immediately.

Sub SendWorkbookByEmail()
    Dim OutApp As Object, OutMail As Object
    Set OutApp  = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To      = "recipient@example.com"
        .Subject = "Monthly Report"
        .Body    = "Hi, please find the report attached."
        .Attachments.Add ActiveWorkbook.FullName
        .Display ' Change to .Send to send without preview
    End With
    Set OutMail = Nothing : Set OutApp = Nothing
End Sub

Windows + Outlook only. Requires Microsoft Outlook to be installed.

Composes and sends a plain text email directly from Excel. Useful for automated notifications or status alerts triggered by a macro.

Sub SendCustomEmail()
    Dim OutApp As Object, OutMail As Object
    Set OutApp  = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To      = "recipient@example.com"
        .Subject = "This is the Subject Line"
        .Body    = "Hello World!"
        .Send
    End With
    Set OutMail = Nothing : Set OutApp = Nothing
End Sub

Windows + Outlook only.

Opens Excel's built-in Send Mail dialog with the workbook attached — works without needing to reference Outlook directly.

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

Windows only. Requires a default mail client to be configured.

Runs Excel's Goal Seek tool programmatically. Update the cell references to match your workbook before running.

Sub GoalSeekVBA()
    Dim Target As Long
    On Error GoTo ErrorHandler
    Target = InputBox("Enter the required value", "Enter Value")
    Worksheets("Sheet1").Activate
    With ActiveSheet.Range("C7")
        .GoalSeek Goal:=Target, ChangingCell:=Range("C2")
    End With
    Exit Sub
ErrorHandler: MsgBox "Sorry, value is not valid."
End Sub

Opens Excel's default data entry form for the active sheet — a fast way to add rows to a table without scrolling or selecting cells.

Sub OpenDataForm()
    ActiveSheet.ShowDataForm
End Sub

Reads out all text values in the selected range using Excel's built-in text-to-speech engine, cell by cell.

Sub SpeakSelection()
    Selection.Speak
End Sub

Windows only. Text-to-speech is not available in Excel for Mac.

Opens the Windows Calculator directly from Excel. Updated to use the Shell method which is more reliable on Windows 10 and 11 than the original ActivateMicrosoftApp.

Sub OpenCalculator()
    Shell "calc.exe", 1
End Sub

Windows only. Will error on Mac.

Opens a Google search in your default browser. Updated to work without a hardcoded Chrome path — now opens in whatever browser is set as your default.

Sub SearchGoogle()
    Dim query As String, searchURL As String
    query = InputBox("Enter your search query", "Google Search")
    If query = "" Then Exit Sub
    searchURL = "https://www.google.com/search?q=" & _
                Application.WorksheetFunction.Substitute(query, " ", "+")
    Shell "cmd /c start """ & searchURL, vbHide
End Sub

Windows only. Opens in your system's default browser.

Runs a 1-minute countdown timer and shows a message box when time is up. Useful for timed tasks or reminders.

Sub SimpleTimer()
    Dim countDown As Date
    countDown = Now + TimeValue("00:01:00")
    Do Until Now >= countDown
        DoEvents
    Loop
    MsgBox "Time's up!"
End Sub

Splits comma-delimited text in a column into separate columns — no need to use the Data → Text to Columns wizard.

Sub TextToColumnsAuto()
    Dim rng As Range
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A100")
    rng.TextToColumns Destination:=rng, DataType:=xlDelimited, Comma:=True
End Sub

Adds a dynamic date to the centre of the page header that updates automatically each time the sheet is printed.

Sub AddDateToHeader()
    With ActiveSheet.PageSetup
        .LeftHeader   = ""
        .CenterHeader = "&D"
        .RightHeader  = ""
    End With
End Sub

Prompts you to type custom text and adds it as the centre page header.

Sub CustomPageHeader()
    Dim myText As String
    myText = InputBox("Enter your header text", "Custom Header")
    ActiveSheet.PageSetup.CenterHeader = myText
End Sub

Configures print settings so all cell comments are printed together on a separate page at the end of the document.

Sub PrintCommentsAtEnd()
    ActiveSheet.PageSetup.PrintComments = xlPrintSheetEnd
End Sub

Adds a large "Confidential" watermark text effect to the active sheet. Adjust the text, font size, and position as needed.

Sub AddWatermark()
    Dim shp As Object
    Set shp = ActiveSheet.Shapes.AddTextEffect( _
        msoTextEffect1, "Confidential", "Arial", 50, msoFalse, msoFalse, 100, 100)
    With shp.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(217, 217, 217)
        .Transparency = 0.5
    End With
End Sub

Quick toggle macros to switch reference styles without navigating Excel Options.

Sub UseR1C1Style()
    Application.ReferenceStyle = xlR1C1
End Sub

Sub UseA1Style()
    Application.ReferenceStyle = xlA1
End Sub

A combined utility macro that both watermarks the active sheet and inserts the current timestamp into cell A1 — useful for version tracking.

Sub WatermarkAndTimestamp()
    ' Add watermark
    ActiveSheet.Shapes.AddTextEffect msoTextEffect1, "DRAFT", "Arial", 60, _
        msoFalse, msoFalse, 150, 200
    ' Add timestamp to A1
    ActiveSheet.Range("A1").Value = "Generated: " & Format(Now(), "dd-mmm-yyyy hh:mm")
End Sub

Refreshes every Power Query connection in the workbook and waits for each to fully complete before moving on. Without setting BackgroundQuery = False, VBA continues executing before the data has finished loading — which causes problems if you have code that runs immediately after the refresh, such as pivot table updates or copy-paste operations.

Sub RefreshAllPowerQueries()
    Dim conn As WorkbookConnection
    For Each conn In ThisWorkbook.Connections
        If conn.Type = xlConnectionTypeOLEDB Or _
           conn.Type = xlConnectionTypePowerQuery Then
            conn.OLEDBConnection.BackgroundQuery = False
            conn.Refresh
        End If
    Next conn
    MsgBox "All Power Query connections refreshed.", vbInformation
End Sub

Refreshes a single named Power Query connection rather than all of them. Useful when you have multiple queries and only want to update one — for example, refreshing a fast "Sales" query without triggering a slow "Historical Data" query that takes minutes to run.

Sub RefreshQueryByName(queryName As String)
    Dim conn As WorkbookConnection
    On Error GoTo NotFound
    Set conn = ThisWorkbook.Connections("Query - " & queryName)
    conn.OLEDBConnection.BackgroundQuery = False
    conn.Refresh
    MsgBox "Query '" & queryName & "' refreshed.", vbInformation
    Exit Sub
NotFound:
    MsgBox "Query '" & queryName & "' not found." & vbNewLine & _
           "Check the name in Data > Queries & Connections.", vbExclamation
End Sub

' Call it like this:
Sub RunRefresh()
    RefreshQueryByName "Sales Data"
End Sub

Writes the name of every Power Query connection in the workbook to a new sheet. Run this first to discover the exact connection names before using the "Refresh by Name" macro — because names must match exactly, including case and spacing.

Sub ListAllQueryNames()
    Dim conn As WorkbookConnection
    Dim ws   As Worksheet
    Dim i    As Integer

    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "Query List"
    ws.Range("A1").Value = "Connection Name"
    ws.Range("B1").Value = "Type"
    ws.Range("A1:B1").Font.Bold = True

    i = 2
    For Each conn In ThisWorkbook.Connections
        ws.Cells(i, 1).Value = conn.Name
        ws.Cells(i, 2).Value = conn.Type
        i = i + 1
    Next conn
    ws.Columns.AutoFit
    MsgBox (i - 2) & " connection(s) listed on the 'Query List' sheet.", vbInformation
End Sub

Sets all Power Query connections to foreground (synchronous) refresh mode. By default Excel refreshes queries in the background while you continue working — but this causes problems when a macro needs to use the data immediately after refreshing. Run this macro once to ensure all subsequent refreshes complete fully before Excel moves on to the next step.

Sub DisableBackgroundRefresh()
    Dim conn As WorkbookConnection
    For Each conn In ThisWorkbook.Connections
        On Error Resume Next
        conn.OLEDBConnection.BackgroundQuery = False
        On Error GoTo 0
    Next conn
    MsgBox "Background refresh disabled for all connections.", vbInformation
End Sub

A complete end-to-end refresh sequence: first refreshes all Power Query connections (waiting for each to finish), then refreshes all pivot tables across every worksheet. Assign this to a "Refresh All" button on your dashboard — one click updates everything in the correct order.

Sub RefreshQueriesThenPivots()
    Dim conn As WorkbookConnection
    Dim ws   As Worksheet
    Dim pt   As PivotTable

    Application.ScreenUpdating = False

    ' Step 1: Refresh all Power Query connections
    For Each conn In ThisWorkbook.Connections
        On Error Resume Next
        conn.OLEDBConnection.BackgroundQuery = False
        conn.Refresh
        On Error GoTo 0
    Next conn

    ' Step 2: Refresh all pivot tables across all sheets
    For Each ws In ThisWorkbook.Worksheets
        For Each pt In ws.PivotTables
            pt.RefreshTable
        Next pt
    Next ws

    Application.ScreenUpdating = True
    MsgBox "All queries and pivot tables refreshed.", vbInformation
End Sub

One of the most common VBA problems with OneDrive is that ThisWorkbook.Path returns a long URL starting with https:// instead of a local file path like C:\Users\.... Many operations — SaveCopyAs, Shell commands, folder creation — fail when given a URL path. This function detects which type of path you have and returns the correct local path in either case.

Function GetLocalPath() As String
    Dim filePath As String
    filePath = ThisWorkbook.FullName

    ' Check if it's a OneDrive/SharePoint URL
    If Left(filePath, 4) = "http" Then
        Dim oneDrivePath As String
        oneDrivePath = Environ("OneDrive")             ' Personal OneDrive
        If oneDrivePath = "" Then
            oneDrivePath = Environ("OneDriveCommercial") ' Work/school OneDrive
        End If
        GetLocalPath = oneDrivePath
    Else
        GetLocalPath = ThisWorkbook.Path ' Already a local path
    End If
End Function

' Test it:
Sub ShowLocalPath()
    MsgBox "Local path: " & GetLocalPath(), vbInformation
End Sub

Saves a timestamped backup of the current workbook directly to your local OneDrive sync folder. Because OneDrive automatically syncs the local folder to the cloud, the file appears in OneDrive online without needing URLs or web APIs. This is the most reliable way to save to OneDrive from VBA.

Sub SaveCopyToOneDrive()
    Dim oneDrivePath As String
    Dim savePath     As String

    ' Get OneDrive local sync folder
    oneDrivePath = Environ("OneDrive")
    If oneDrivePath = "" Then oneDrivePath = Environ("OneDriveCommercial")

    If oneDrivePath = "" Then
        MsgBox "OneDrive folder not found on this computer.", vbExclamation
        Exit Sub
    End If

    ' Create Backups subfolder if it doesn't exist
    If Dir(oneDrivePath & "\Backups", vbDirectory) = "" Then
        MkDir oneDrivePath & "\Backups"
    End If

    savePath = oneDrivePath & "\Backups\" & _
               Format(Now(), "yyyymmdd_hhmmss") & "_backup.xlsm"

    ThisWorkbook.SaveCopyAs savePath
    MsgBox "Backup saved to OneDrive:" & vbNewLine & savePath, vbInformation
End Sub

When a file is on SharePoint or a shared network drive, another user may have it open and locked. Trying to open or write to a locked file causes a runtime error. This function checks whether a file is currently locked before attempting to open it — saving your macro from an unexpected crash.

Function IsFileLocked(filePath As String) As Boolean
    Dim fileNum As Integer
    fileNum = FreeFile
    On Error Resume Next
    Open filePath For Input Lock Read As #fileNum
    If Err.Number <> 0 Then
        IsFileLocked = True  ' File is locked
    Else
        Close #fileNum
        IsFileLocked = False
    End If
    On Error GoTo 0
End Function

' Example — check before opening:
Sub SafeOpenFile()
    Dim path As String
    path = "C:\Shared\Report.xlsx"
    If IsFileLocked(path) Then
        MsgBox "This file is currently open by another user." & vbNewLine & _
               "Please try again in a few minutes.", vbExclamation
    Else
        Workbooks.Open path
    End If
End Sub

When a workbook is open from OneDrive, ThisWorkbook.Save triggers an AutoSave sync which can be slow, cause version conflicts, or fail entirely with a co-authoring error. This macro temporarily disables AutoSave, forces a clean local save, then restores AutoSave to its original state — giving you a fast, reliable save that doesn't depend on your internet connection.

Sub ForceSaveLocal()
    Dim wasAutoSave As Boolean

    ' Remember current AutoSave state and turn it off
    On Error Resume Next
    wasAutoSave = ThisWorkbook.AutoSaveOn
    ThisWorkbook.AutoSaveOn = False
    On Error GoTo 0

    ' Save the workbook
    ThisWorkbook.Save

    ' Restore AutoSave to its original state
    On Error Resume Next
    ThisWorkbook.AutoSaveOn = wasAutoSave
    On Error GoTo 0

    MsgBox "File saved successfully.", vbInformation
End Sub