VBA Snippets - abdullahbintahir/Python-Snippet GitHub Wiki

'Disable alerts

Application.DisplayAlerts = False

'Sorting amounts highest to lowest

Range("A1").CurrentRegion.Sort Key1:=Rows(1).Find("*TEXTHERE*"), Order1:=xlDescending, Header:=xlYes

Custom sort based on one specific criteria

    i = 1
    For Each cell In Columns("I:I").Cells
        If cell.Value = "Donations" Then
            rw = cell.Row
            i = i + 1
            cell.EntireRow.Cut Destination:=Rows(i)
            Rows(rw + 1).Delete
        End If
    Next cell

'Filtering in by single criteria

Range().AutoFilter Field:=_ColumnNumber_, Criteria1:="_Text/value_"

'Filtering in based on array

Range().AutoFilter Field:=_ColumnNumber_, Criteria1:=Array("Text1","Text2","Text3"), Operator:= xlFilterValues

Filtering out zeros and blanks (only 2 values allowed max

ActiveSheet.Range(Rng).AutoFilter Field:=Rows(4).Find("").Column, Criteria1:="<>0", Operator:=xlAnd, Criteria2:="<>"

'Deleting visible cells only except header

Range("A1").CurrentRegion..Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

'For each loop including breaking the loop

For each i in Range()
  Break For
Next i

'If/ else condition

If _condition_ then
End if

'Removing duplicates from a range

Range().RemoveDuplicates Columns:=_n_, Header:=xlNo

'Msgbox with yes/no buttons

Var_name = MsgBox("_QuestionText_", vbQuestion + vbYesNo + vbDefaultButton1, "_WindowName_")

'Get file path/directories

Var_name = Application.GetOpenFilename(, , "_WindowName_",,True)

'Copy Paste the range as values + Formats

Range().PasteSpecial xlPasteValues,Transpose:=True
Range().PasteSpecial xlPasteFormats,Transpose:=True
Application.CutCopyMode = False

'Open an existing workbook

Workbooks.open _Path_

'Close a workbook


'Address of range or cell


'Column number or row number




'Inset a formula

ActiveCell.Formula = "=_Formula_"
Note: Text within the formula needs to have 2 double quotes i.e. ""Amount""

'Autofill/ Drag down

Range().AutoFill Destination:=Range()

'Toggle autofilter on/off


'clear filtering


'Inserting a column or row

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

'deleting a column or row

Selection.Delete Shift:=xlToLeft

'Input box

Var_Name = InputBox("_QuestionText_", "_WindowName_")

'Merging cells


'Formatting numbers as comma seperated

Selection.Style = "Comma"

'Alignment of text

Range().HorizontalAlignment = xlCenter

Putting all borders

Range().Borders.LineStyle = xlContinuous

Putting top, bottom ,left, right borders

Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous

Butting white borders

Range("").Borders(xlEdgeTop).ThemeColor = 1

'Hiding gridlines

ActiveWindow.DisplayGridlines = False

'Advanced filter

Range().AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range(), Unique:=False

'Font size

Range().Font.Size = 16

'Autofit a column


'Adding a hyperlink

ActiveSheet.Hyperlinks.Add Anchor:=_Selection_, Address:="_https_", TextToDisplay:="_Text_"

'Format specific words in a text

ActiveCell.Characters(Start:=23, Length:=28).Font.Underline = xlUnderlineStyleSingle

'Dynamic file path

ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\Downloads\DTIT " & Format(Date, "MMMM DD YYYY") & ".xlsx"

'Hiding a worksheet


'Hide a column


Creating a table

ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Table1"

Selecting whole table


Selecting a specific column


Selecting only the table's header


Filtering a certain column in table

Range("Table1[#All]").AutoFilter Field:=n, Criteria1:= "whatever"

Removing banded rows from the table

ActiveSheet.ListObjects("Table1").ShowTableStyleRowStripes = False

Finding values with different requirements

Rows(1).Find(What:="_TextORValue_", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchDirection:=xlPrevious)

Removing columns based on color

    Workbooks(MAcro_Workbook).Sheets("Deal Summary").Activate
    For Each cell In Rows(1).Cells
        If cell.Interior.Color <> RGB(146, 208, 80) Then
        End If
    Next cell

Adding Index Column

   For Each cell In Range("B2:B10000").Cells
    If Not IsEmpty(cell.Value) Then
        i = i + 1
        cell.Offset(, -1).Value = i
    End If
    Next cell

Unwrap text

    Cells.WrapText = False

Making Font color black

    Rows(1).Font.ThemeColor = xlThemeColorLight1

Autofit columns


Formatting column as Date

Rows(1).Find("Text").EntireColumn.NumberFormat = "m/d/yyyy"

Formatting entire column as currency

Rows(1).Find("Text").EntireColumn.Style = "Currency"

Formatting column as %

Rows(1).Find("Text").EntireColumn.Style = "Percent"

Remove decimals from a column

Rows(1).Find("Text").EntireColumn.NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""??_);_(@_)"

Disable update links prompt

Application.AskToUpdateLinks = False

Putting a Date and Time stamp

Selection.Value = Now

Fill down (copy)

Selection.AutoFill Destination:=Range(), Type:=xlFillCopy

Putting "Processing....." at the main sheet

Range("C8").Value = "Processing........."
Range("C8").Font.Color = -16776961
Range("C8").Font.Bold = True
Range("C8").Font.Size = 20
Range("C8").Font.Name = "Calibri"
Application.Wait Now + TimeValue("00:00:02")
Application.ScreenUpdating = False

Trigger macro based on cell change

Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address = "$C$4" Then
           Actual Code
        End If
End Sub

Trigger Macro based on change in any cell in a range

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("B7:B30")) Is Nothing Then
     For Each cell In Target
   End If

End Sub

Trigger Macro based on sheet activation

    If Sheets("Custom Request").Activate Then
       Actual code  
    End If

End Sub

Formatting number as percentage and 2 decimal points

Format(number, "0.00%")

Format number in millions M and 2 decimal points

Format(number / 1000000, "#.00") & " M"

Put a line break in message box

MsgBox ("msg" & vbNewLine & "msg")

Count code run time

StartTime = Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "The code took " & SecondsElapsed & " seconds to run.", vbInformation

Remove conditional formatting


Yes/No question/ mesgbox

Ques = MsgBox("Are there any claims under review from yesterday?", vbQuestion + vbYesNo + vbDefaultButton1, "Deloitte.")
If Ques = 6 Then
End if

Setting dimensions of USerform

Private Sub UserForm_Initialize()
    ' Fixing Userform's Size
    Me.Height = 200
    Me.Width = 800
    ' Fixing Text Box size
    TextBox1.Height = 200
    TextBox1.Width = 788
    TextBox1.Font.Size = 10
    ' Centering Userform on the primary screen
    Me.StartUpPosition = 0
    Me.Left = Application.Left + (Application.Width - Me.Width) / 2
    Me.Top = Application.Top + (Application.Height - Me.Height) / 2
End Sub

Toggle calculation mode between auto or manual

Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
Worksheets("Custom Request").Calculate

Changing Chart Source

ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SetSourceData Source:=Range("A1:C" & rw)

Protect/ Unprotect Sheet

ActiveSheet.Unprotect Password:="YourPassword"
ActiveSheet.Protect Password:="YourPassword"

Display options in Excel

ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
CommandBars.ExecuteMso "HideRibbon"

VBA Errors

Subscript out of range ---object not found
Select method of worksheet class failed ---syntax has ".Select" which is an issue
object variable/ with block variable not set---variable not found
Type mismatch error---->trying to perform operation on different variable type i.e. dividing string by integer