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
            Rows(i).Insert
            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()
  _Operation_
  Break For
Next i

'If/ else condition

If _condition_ then
 _Operation_
Else
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().copy
Range().PasteSpecial xlPasteValues,Transpose:=True
Range().PasteSpecial xlPasteFormats,Transpose:=True
Application.CutCopyMode = False

'Open an existing workbook

Workbooks.open _Path_

'Close a workbook

Workbooks(_name_).close

'Address of range or cell

Range().address
Activecell.address

'Column number or row number

Range().column
Range().row

'offsetting

Range().offset(_NumberOfRows_,_NumberOfColumns_)

'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

Cells.autofilter

'clear filtering

cells.showalldata

'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

Range().merge

'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

Range("C5").Select
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

Columns().EntireColumn.AutoFit

'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

activesheet.visible=False

'Hide a column

 Columns(1).hidden=True

Creating a table

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

Selecting whole table

Range("Table1[#All]").Select

Selecting a specific column

Range("Table1[ColumnName]").Select

Selecting only the table's header

Range("Table1[[#Headers],[ColumnName]]").Select

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
            cell.EntireColumn.Delete
        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

    Cells.EntireColumn.AutoFit

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

Range().FormatConditions.Delete

Yes/No question/ mesgbox

Ques = MsgBox("Are there any claims under review from yesterday?", vbQuestion + vbYesNo + vbDefaultButton1, "Deloitte.")
If Ques = 6 Then
Else
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.CalculateFull
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

Creating Outlook email

Dim DataObj As MSForms.DataObject
    Set DataObj = New MSForms.DataObject
    DataObj.GetFromClipboard

    Dim OlApp As Outlook.Application
    Dim ObjMail As Outlook.MailItem
    Set OlApp = Outlook.Application
    Set ObjMail = OlApp.CreateItem(olMailItem)

    With ObjMail
        .Display
        .To = "[email protected]"
        .CC = "[email protected];[email protected];[email protected];[email protected];[email protected];[email protected];[email protected];[email protected]"
        .Subject = "Canada CX Renewals - Services | Actuals Bookings Report | " & Format(Date, "M.DD.YYYY ") & Quarter & "'" & FY
        .HTMLBody = "<div style='font:11 Calibri'>" _
                    & "Team," & "<br><br>" _
                    & "Please find below the link to the " & "<b>" & Quarter & FY & "</b>" & " Actuals/Bookings report as of today." & "<br><br>" _
                    & "Link--> <a href='https://cisco.sharepoint.com/sites/OneSiteCanadaRenewals/Shared%20Documents/Forms/AllItems.aspx?ga=1&id=%2Fsites%2FOneSiteCanadaRenewals%2FShared%20Documents%2FFinance%2FActuals&viewid=9e1b32c4%2D5269%2D4c8e%2D86f4%2D5d24789b77b0'>Actuals</a>" & "<br>" _
                    & ObjMail.GetInspector.WordEditor.Application.Selection.Paste _
                    & .HTMLBody
        '.Attachments.Add ActiveWorkbook.FullName
    End With
    
    Set OlApp = Nothing
    Set ObjMail = Nothing

'Moving previous Excel file to 'Previous' folder

    'Set the source and destination folders
    sourceFolder = "C:\Users\abtahir\OneDrive - Cisco\SFDC\"
    destinationFolder = "C:\Users\abtahir\OneDrive - Cisco\SFDC\New Version Funnel\"
    
    'Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
'    ' Check if destination folder exists, if not, create it
'    If Not FSO.FolderExists(destinationFolder) Then
'        FSO.CreateFolder (destinationFolder)
'    End If
    
    ' Get the first file in the source folder
    Filename = Dir(sourceFolder & "*.xlsx")
    MsgBox (Filename)
    
    ' Loop through all the Excel files in the source folder
    Do While Filename <> ""
        ' Move the file to the destination folder
        FSO.MoveFile sourceFolder & Filename, destinationFolder & Filename
        ' Get the next file
        Filename = Dir
    Loop

Import data column by column

'Determining data dimensions
    LastRow = InputWorkbook.Sheets(1).Range("A1048576").End(xlUp).Row
    
    'Main Loop
    For Each Field In MainWorksheet.Range("A1:" & MainWorksheet.Range("A1").End(xlToRight).Address)
        Set FoundCell = InputWorkbook.Sheets(1).Rows(1).Find(Field.Value)
        If Not FoundCell Is Nothing Then
            Clm = FoundCell.Column
            InputWorkbook.Sheets(1).Range(InputWorkbook.Sheets(1).Cells(2, Clm), InputWorkbook.Sheets(1).Cells(LastRow, Clm)).Copy
            MainWorksheet.Cells(2, Field.Column).PasteSpecial xlPasteValues
        Else
            MsgBox (Field.Value & "Column not found")
        End If
    Next Field
    InputWorkbook.Close
⚠️ **GitHub.com Fallback** ⚠️