Snippet Excel VBA

With snippet Excel VBA, you can free your mind

  1. Functions

    a. Create Module File: (Menu > Insert > Module)

    b. Define Function

    ' Pass by Value: ByVal InputPath As String
    ' Pass by Reference: DataCollector As Collection
    ' Function return void
    Private Sub ReadFile (DataObjectCollector As Collection, ByVal InputPath As String)
      ' Your Code
      ' Exit Sub
    End Sub
    ' Function return a value or a collection
    Public Function DataObjectToArray(ByVal Data As DataObject)
      Dim Result(21) As String
      ' Your Code
      DataObjectToArray = Result
    End Function
    ' Function return object
    Public Function GetAllDataObject(ByVal inputPath1 As String, ByVal inputPath2 As String)
      Dim Result As New Collection
      'Your Code
      Set GetAllDataObject = Result
    End Function
    

    c. Usage

    ' Call Sub Function
    ReadFile DataObjectCollector, inputPath
    ' Call Function
    Set Result = Merge(Result, AnotherFunction(Param1, Param2, Param3))
    
  2. Class

    a. Create Class: (Menu > Insert > Class Module)

    b. Define Class

    Public property1 As String
    Public property2 As String
    Public Sub Method(ByVal Param1 As String, ByVal Param2 As Integer)
      'Your Method Code
    End Sub
    

    c. Usage

    Dim Data = New DataObject
    Data.property1 = "My value"
    MsgBox Data.property1 & " is not null"
    
  3. Array

    ' Declare
    Dim dataPart() As String
    ' Usage
    dataPart(0) = "Zero"
    MsgBox dataPart(0)
    
  4. Collection

    ' Declare
    Dim Data As New Collection
    ' Usage
    Data.Add Item, Data.Remove Item, Data.Count
    
  5. For Loop

    ' Traditional for loops
    For i = 0 To 10
      'Your Code
    Next i
    ' Iterator-based for loops
    For Each cell In Range("T1:V2").Cells
      'Your Code
    Next
    For Each item In DataCollection
      'Your Code
    Next
    
  6. Conditions

    If condition_1 Then
      'result_1
    ElseIf condition_2 Then
      'result_2
    Else
      'result_else
    End If
    
  7. File Open Dialog

    ' Get full path of file
    FullFilePath = Application.GetOpenFilename("*.*,*.*")
    
  8. File System Object

    ' Required Lib: Microsoft Scripting Runtime
    ' Check file exist
    Dim fso As New FileSystemObject
    fso.fileExists(inputPath)
    ' Read file line by line
    Dim fso As New FileSystemObject
    Dim ts As TextStream
    ' fso.OpenTextFile(filename[, iomode[, create[, format]]])
    ' iomode: 1 (reading only), 2 (writing), 8 (write to the end of the file)
    ' create: True (new file created if the specified filename doesn't exist),
    '         False (a new file isn't created)
    ' format: -2 (system default), -1 (unicode), 0 (ASCII)
    Set ts = fso.OpenTextFile(InputPath)
    Do Until ts.AtEndOfStream
      sLine = ts.ReadLine
    Loop
    ts.Close
    Set ts = Nothing
    Set fso = Nothing
    
  9. ADODB.Stream

    ' Required Lib: Microsoft ActiveX Data Objects 2.7 Library
    ' Initialize
    Dim st As New ADODB.Stream
    ' Set parameter
    ' adTypeBinary <=> 1, adTypeBinary <=> 2
    ' adTypeBinary, adTypeText is constant and adTypeText is default
    st.Type = adTypeText
    ' encoding is SJIS, JIS, EUC, UTF-7, UTF-8
    st.Charset = "UTF-8"
    ' set line separator to line feed,
    ' adCRLF, adLF, adCR. Default is adCRLF
    st.LineSeparator = adLF
    ' Read file
    st.Open
    st.LoadFromFile (FilePath)
    Do While Not (st.EOS)
      'adReadAll <=> -1, adReadLine <=> -2, and
      'adReadAll, adReadLine is constant and adReadAll is default
      sLine = st.ReadText(adReadLine)
    Loop
    st.Close
    Set st = Nothing
    
  10. Select Case

    Select Case test_expression
      Case condition_1
      'Case 1 To 10
      'Case 1, 2
      'Case Is < 100
        result_1
      Case condition_2
        result_2
      Case Else
      result_else
    End Select
    
  11. DateTime

    ' Get now
    DateTime.Now
    ' Format date with pattern
    Format(DateTime.Now, "yyyymmddhhMMss")
    
  12. Converter

    CBool(variable)
    CByte(variable)
    CCur(variable)
    CDate(variable)
    CDbl(variable)
    CDec(variable)
    CInt(variable)
    CLng(variable)
    CSng(variable)
    CStr(variable)
    CVar(variable)
    
  13. Exception

    ' If error occur then jump to (GoTo) code block marked (ErrorHandler)
    Private Sub ReadFileWithoutEncoding(DataCollector As Collection, ByVal InputPath As String)
      On Error GoTo ErrorHandler
      ReadFile DataCollector, InputPath, "UTF-8"
      Exit Sub
    ErrorHandler:
      ReadFile DataCollector, InputPath, "SJIS"
    End Sub
    ' Ignore error
    For Each cell In Sheets(SheetName).UsedRange.Cells
      On Error Resume Next
      If Not IsEmpty(cell.Value) Then
        cell.Value = CDec(cell.Value)
      End If
    Next
    
  14. Sheet

    ' Keep ActiveSheet in a safe place
    Set ProcessSheet = ActiveSheet
    ' Get Process Sheet's name
    ProcessSheetName = ProcessSheet.Name
    ' Select Sheet by index
    Sheets(0).Select
    ' Select Sheet by Name
    Sheets(ProcessSheetName).Select
    ' Create a new Sheet after active Sheet
    Sheets.Add(After:=ActiveSheet).Name = "New Sheet Name"
    ' Auto fit all collumns
    Sheets(SheetName).Cells.EntireColumn.AutoFit
    ' Add filter to Sheet
    Sheets(SheetName).Select
    Selection.AutoFilter
    ' Freeze first line
    With ActiveWindow
      .SplitColumn = 0
      .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    
  15. Range

    ' Loop all cells in the Used Range
    ' (last column and last row are Range Area)
    For Each cell In Sheets(SheetName).UsedRange.Cells
      'Your Code
    Next
    ' Convert all cells in Used Range to decimal
    For Each cell In Sheets(SheetName).UsedRange.Cells
      On Error Resume Next
      If Not IsEmpty(cell.Value) Then
        cell.Value = CDec(cell.Value)
      End If
    Next
    ' Fill data of an array to a Sheet's row
    header = Array("Colunm1", "Colunm2", "Colunm3", "Colunm4", "Colunm5")
    Sheets(SheetName).Range("A1:E1").Value = header
    
  16. Cell

    ' Assign a formual to cell
    Range("P" & Index + 2).Formula = "=SUBTOTAL(9,P2:P" & Index & ")/10000"
    ' Set number format for multi-cols (Decimal places: 0; 1000 sepatator (,))
    Columns("P:Q").NumberFormat = "#,##0"
    ' Set currency format to cell
    Range("P" & Index + 2).NumberFormat = "_ ""\""* #,##0_ ;_ ""\""* -#,##0_ ;_ ""\""* ""-""_ ;_ @_ "
    ' Set percent format to cell
    Range("R" & Index + 2).NumberFormat = "0%"
    ' Set color background for cell
    With Sheets(SheetName).Range("A1:T1").Interior
      .Color = 0
      .TintAndShade = 0.8
    End With
    ' Set text color and bold in cell
    With Sheets(SheetName).Range("A1:T1").Font
      .ThemeColor = xlThemeColorDark1
      .Bold = True
    End With
    ' Set border for cell
    With cell.Borders
      .Weight = xlThin
    End With
    
  17. Show All Formulas Named

    Dim n As Name
    For Each n In ActiveWorkbook.Names
      n.Visible = True
    Next
    
  18. Regular Expressions

    ' Require Lib: Microsoft VBScript Regular Expressions 5.5
    ' Find string which between two double quotes characters,
    ' to remove comma and double quotes character from this
    Private Function FieldParser(ByVal Str As String)
    Dim Regex, Match, Item
    Set Regex = CreateObject("VBScript.RegExp")
    Regex.Pattern = """[^""]*,*[^""]*"""
    Regex.Global = True
    For Each Match In Regex.Execute(Str)
      ' Remove all comma character
      Item = Replace(Match.Value, ",", vbNullString)
      ' Remove all double quotes character
      Item = Replace(Item, """", vbNullString)
      Str = Replace(Str, Match.Value, Item)
    Next
    FieldParser = Split(Str, ",")
    End Function
    ' Find string which separator by comma character,
    ' ignore comma between consecutive double quotes,
    ' to remove comma and double quotes character from this
    Private Function FieldParser(ByVal Str As String)
    ReDim Result(0) As String
    Dim Regex, Match, Previous, Current
    Set Regex = CreateObject("VBScript.RegExp")
    Regex.Pattern = """[^""]*""|[^,]*"
    Regex.Global = True
    For Each Match In Regex.Execute(Str)
      If Match.Length > 0 Or Previous = "" Then
        ReDim Preserve Result(UBound(Result) + 1)
        Current = Replace(Match.Value, ",", vbNullString)
        Result(UBound(Result) - 1) = Replace(Current, """", vbNullString)
      End If
      Previous = Match.Value
    Next
    FieldParser = Result
    End Function
    
  19. Join Values with Conditions of Another Values by Array Formulas

    Create a Module in VBA:

    Public Function JOIN(arr()) As String
      For i = LBound(arr) To UBound(arr)
        If arr(i, 1) <> "" Then
          ' join with comma append prefix
          JOIN = JOIN & "," & arr(i, 1)
        End If
      Next
      ' remove first comma if has content
      If Len(JOIN) > 0 Then
        JOIN = Right(JOIN, Len(JOIN) - 1)
      End If
    End Function
    

    Usage in excel spreadsheet:

    =JOIN(IF(B15:B30="OK",$A15:$A30,"")) + N("join value of A15:A30 if B15:B30 is OK.")
    

    Press CTRL+SHIFT+ENTER to enter the array constant as an array formula

  20. Find If Cell Contains String

    =IF(ISNUMBER(SEARCH("find_text",A1)),A1,"")
    
    • SEARCH - help you find location of find_text in A1. Unlike FIND, SEARCH allows the use of wildcards, and is not case-sensitive
    • ISNUMBER - help you test for numeric value, return TRUE when value is numeric and FALSE when not
    • IF - as you know

Comments

Popular posts from this blog

Reduce TIME_WAIT Socket Connections