Select the VBA category you need VBA code for:

VBA Answers

Copy data from one worksheet to another

Sub CopyData()
    Sheets("Sheet1").Range("A1:D10").Copy _
    Destination:=Sheets("Sheet2").Range("A1")
End Sub
Click to see it in action

Delete blank rows

Sub DeleteBlankRows()
    On Error Resume Next
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Click to see it in action

Find last used row

Sub FindLastRow()
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    MsgBox lastRow
End Sub
no link yet

Loop through all worksheets

Sub LoopSheets()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        MsgBox ws.Name
    Next ws
End Sub
no link yet

Protect and unprotect a sheet

Sub ProtectSheet()
    ActiveSheet.Protect Password:="mypassword"
End Sub

Sub UnprotectSheet()
    ActiveSheet.Unprotect Password:="mypassword"
End Sub
no link yet

Highlight duplicates

Sub HighlightDuplicates()
    Columns("A").FormatConditions.AddUniqueValues
    Columns("A").FormatConditions(Columns("A").FormatConditions.Count).SetFirstPriority
    Columns("A").FormatConditions(1).DupeUnique = xlDuplicate
    Columns("A").FormatConditions(1).Interior.Color = vbYellow
End Sub
no link yet

Export Excel range to CSV

Sub ExportToCSV()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Copy
    ActiveWorkbook.SaveAs Filename:="C:Tempexport.csv", FileFormat:=xlCSV
    ActiveWorkbook.Close False
End Sub
no link yet

Import CSV into Excel

Sub ImportCSV()
    Workbooks.Open Filename:="C:Tempdata.csv"
End Sub
no link yet

Merge multiple workbooks

Sub MergeWorkbooks()
    Dim wb As Workbook, f As String
    f = Dir("C:Files*.xlsx")
    Do While f <> ""
        Set wb = Workbooks.Open("C:Files" & f)
        wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        wb.Close False
        f = Dir
    Loop
End Sub
no link yet

Auto-fit all columns

Sub AutoFitColumns()
    Cells.EntireColumn.AutoFit
End Sub
no link yet

Insert row and copy formulas

Sub InsertRowCopyFormulas()
    Rows(2).Insert Shift:=xlDown
    Rows(3).Copy
    Rows(2).PasteSpecial xlPasteFormulas
End Sub
no link yet

Sort data by column

Sub SortByColumn()
    Range("A1:D100").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes
End Sub
no link yet

Generate PDF from sheet

Sub ExportToPDF()
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Temp\Report.pdf"
End Sub
no link yet

Copy visible rows only

Sub CopyVisibleRows()
    On Error Resume Next
    ActiveSheet.AutoFilter.Range.Copy Destination:=Sheets("Sheet2").Range("A1")
End Sub
no link yet

Combine data from all sheets

Sub CombineSheets()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.UsedRange.Copy ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next
End Sub
no link yet

Create a backup copy of workbook

Sub BackupWorkbook()
    ThisWorkbook.SaveCopyAs "C:\Backup\" & ThisWorkbook.Name
End Sub
no link yet

Send bulk personalized emails

Sub SendBulkEmails()
    Dim OutApp As Object, OutMail As Object, i As Long
    Set OutApp = CreateObject("Outlook.Application")
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Cells(i, 1).Value
            .Subject = "Hello " & Cells(i, 2).Value
            .Body = "Dear " & Cells(i, 2).Value & ", this is your update."
            .Send
        End With
    Next
End Sub
no link yet

Convert formulas to values

Sub ConvertToValues()
    Selection.Value = Selection.Value
End Sub
no link yet

Apply conditional formatting via VBA

Sub AddCondition()
    Range("A1:A10").FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=100"
    Range("A1:A10").FormatConditions(1).Interior.Color = vbYellow
End Sub
no link yet

Create message box reminders

Sub DailyReminder()
    MsgBox "Don’t forget to back up your work today!", vbInformation
End Sub
no link yet

Auto-run macros on open

Sub Auto_Open()
    MsgBox "Welcome! This macro runs on open."
End Sub
no link yet

Detect and log errors to a text file

Sub LogErrors()
    On Error GoTo ErrHandler
    Dim x As Integer
    x = 1 / 0
    Exit Sub
ErrHandler:
    Open "C:\Temp\ErrorLog.txt" For Append As #1
    Print #1, Now & " - " & Err.Description
    Close #1
End Sub
no link yet

Format as table

Sub FormatAsTable()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.ListObjects.Add(xlSrcRange, Range("A1:D10"), , xlYes).Name = "DataTable"
End Sub
no link yet

Add new worksheet if not exists

Sub AddSheetIfNotExists()
    On Error Resume Next
    If Sheets("Report") Is Nothing Then Sheets.Add.Name = "Report"
    On Error GoTo 0
End Sub
no link yet

Create timestamp when edited

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A100")) Is Nothing Then
        Target.Offset(0, 1).Value = Now
    End If
End Sub
no link yet

Clean data (trim spaces, remove special chars)

Sub CleanData()
    Dim c As Range
    For Each c In Selection
        c.Value = WorksheetFunction.Trim(c.Value)
        c.Value = Replace(c.Value, Chr(160), "")
    Next
End Sub
no link yet

Backup before close

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.SaveCopyAs "C:\Backup\" & Format(Now, "yyyymmdd_hhnnss") & "_" & ThisWorkbook.Name
End Sub
no link yet

Prompt user for filename

Sub SaveWithPrompt()
    Dim fName As String
    fName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx")
    If fName <> "False" Then ActiveWorkbook.SaveAs fName
End Sub
no link yet

Automate chart creation

Sub CreateChart()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.SetSourceData Source:=Sheets("Sheet1").Range("A1:B10")
    ch.ChartType = xlColumnClustered
    ch.Location xlLocationAsObject, "Sheet1"
End Sub
no link yet

Email Excel range as image 

Sub EmailRangeAsImage()
    Range("A1:D10").CopyPicture xlScreen, xlPicture
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "someone@example.com"
        .Subject = "Excel Range"
        .Display
        .GetInspector.WordEditor.Range.Paste
    End With
End Sub
no link yet

Search and highlight keywords

Sub HighlightKeyword()
    Dim cell As Range
    For Each cell In Range("A1:A100")
        If InStr(1, cell.Value, "Error", vbTextCompare) > 0 Then
            cell.Interior.Color = vbYellow
        End If
    Next
End Sub
no link yet

Convert selected range to JSON

Sub RangeToJSON()
    Dim r As Range, c As Range, s As String
    Set r = Selection
    s = "["
    For Each c In r
        s = s & """" & c.Value & ""","
    Next
    s = Left(s, Len(s) - 1) & "]"
    MsgBox s
End Sub
no link yet

Create dynamic named range

Sub DynamicNamedRange()
    ThisWorkbook.Names.Add Name:="MyData", RefersTo:="=OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1)"
End Sub
no link yet

Split one sheet into multiple files

Sub SplitSheet()
    Dim r As Range, cell As Range
    Set r = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    For Each cell In r
        Sheets("Template").Copy
        ActiveWorkbook.SaveAs "C:\Split\" & cell.Value & ".xlsx"
        ActiveWorkbook.Close False
    Next
End Sub
no link yet

Apply data validation

Sub AddDataValidation()
    With Range("B2:B20").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="Yes,No,Maybe"
    End With
End Sub
no link yet

Combine all CSV files in folder

Sub CombineCSV()
    Dim f As String
    f = Dir("C:\CSV\*.csv")
    Do While f <> ""
        Workbooks.Open Filename:="C:\CSV\" & f
        ActiveSheet.UsedRange.Copy ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Workbooks(f).Close False
        f = Dir
    Loop
End Sub
no link yet

Copy/paste visible cells only

Sub CopyVisibleCellsOnly()
    On Error Resume Next
    Selection.SpecialCells(xlCellTypeVisible).Copy
    Sheets("Sheet2").Range("A1").PasteSpecial xlPasteValues
End Sub
no link yet

Remove duplicates programmatically

Sub RemoveDuplicates()
    Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
no link yet