Thursday, 19 November 2015

Useful VBA Utilities for Microsoft Excel & Data Handling

Useful VBA Utilities for Microsoft Excel & Data Handling

Author: Eddie Shrivastava

In recent years, whilst working on a various Data-projects (Data Engineering, Data Analysis and Data Warehouse projects) as a DBA/Data Engineer, I noticed that whilst for handling large datasets it's better to use specific technologies such as: SSIS, PowerShell, T-SQL etc. however, for smaller datasets, Excel is sill handy (in 2021) for some quick data transformations. Considering this, I made use of good old Excel VBA / Macros, which turned out to be very useful and time saving, therefore, I would like to share some of my code snippets especially the ones that are generic in nature i.e. they can be re-used in diverse scenarios and can be useful for other Data professionals. I'm happy for my code to be re-used (without any attached strings of licences).


VBA Code Templates & Samples:

' Following code converts a number written as words/alphabets (e.g. One, Two) into digits as 1 to 9
Function GetDigit(WordedNumber)
    WordedNumber = WorksheetFunction.Proper(WordedNumber) 'important for consistent results.
    Select Case WordedNumber
        Case "One", "0ne": GetDigit = 1
        Case "Two", "Tw0": GetDigit = 2
        Case "Three": GetDigit = 3
        Case "Four": GetDigit = 4
        Case "Five": GetDigit = 5
        Case "Six": GetDigit = 6
        Case "Seven": GetDigit = 7
        Case "Eight": GetDigit = 8
        Case "Nine": GetDigit = 9
        Case "Ten": GetDigit = 10
        Case "Eleven": GetDigit = 11
        Case "Twelve": GetDigit = 12
        Case "Thirteen": GetDigit = 13
        Case "Fourteen": GetDigit = 14
        Case "Fifteen": GetDigit = 15
        Case "Sixteen": GetDigit = 16
        Case "Seventeen": GetDigit = 17
        Case "Eighteen": GetDigit = 18
        Case "Nineteen": GetDigit = 19
        Case "Twenty": GetDigit = 20
        Case Else: GetDigit = ""
    End Select
End Function


' Following code converts digits as 1 to 9 into number written as words/alphabets.
Function GetWordedNumbers(Digit)
    Select Case Val(Digit)
        Case 1: GetWordedNumbers = "One"
        Case 2: GetWordedNumbers = "Two"
        Case 3: GetWordedNumbers = "Three"
        Case 4: GetWordedNumbers = "Four"
        Case 5: GetWordedNumbers = "Five"
        Case 6: GetWordedNumbers = "Six"
        Case 7: GetWordedNumbers = "Seven"
        Case 8: GetWordedNumbers = "Eight"
        Case 9: GetWordedNumbers = "Nine"
        Case 10: GetWordedNumbers = "Ten"
        Case 11: GetWordedNumbers = "Eleven"
        Case 12: GetWordedNumbers = "Twelve"
        Case 13: GetWordedNumbers = "Thirteen"
        Case 14: GetWordedNumbers = "Fourteen"
        Case 15: GetWordedNumbers = "Fifteen"
        Case 16: GetWordedNumbers = "Sixteen"
        Case 17: GetWordedNumbers = "Seventeen"
        Case 18: GetWordedNumbers = "Eighteen"
        Case 19: GetWordedNumbers = "Nineteen"
        Case 20: GetWordedNumbers = "Twenty"
        Case Else: GetWordedNumbers = ""
    End Select
End Function


Looping through Objects:


Looping through Workbooks / Excel Files:

Example-1:
'following code loops through workbooks
'following code loops through all OPEN workbooks then displays those book-names:
Sub LoopingThroughBooks()
    For Each book In Workbooks
        Text = Text & book.Name & vbNewLine
    Next book
    MsgBox Text
End Sub

Looping through Sheets:

Example-1:
'following code loops through worksheets in current workbook then displays those sheet-names:
Sub LoopingThroughSheets()
    For Each sheet In Worksheets
        Text = Text & sheet.Name & vbNewLine
    Next sheet
    MsgBox Text
End Sub

Looping through Columns or Rows:

Example-0: looping through Rows
'Following code loops through the 1st row to the last row:
Sub LoopingRows()
    Dim LastRow As Long, r As Long
    'LastRow = ActiveSheet.UsedRange.Rows.Count
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For r = 1 To LastRow
        ' Your code here
    Next r
End Sub

Example-1:
'First find out the last row / column then simply do a counter-loop:
Sub UsedRangeColsRows()
    Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long
    
    LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    LastColCount = ActiveSheet.UsedRange.Columns.Count
    Debug.Print LastRow
    Debug.Print LastCol & " which is same as " & LastColCount
   
    For c = 1 To LastCol
        For r = 1 To LastRow
            If Cells(r, c) = "MyCheck" Then
                 ' Your code here
            End If
        Next r
    Next c
End Sub

Example-2:
'This code loops through & hides all columns except column-headers written in the 'arr' array.
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub HideCols()
    Dim arr As Variant   'arr must Variant or String type as Range() & Split() return Sub-Strings (array).
    Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long
    arr = Split("1.8 Station Ground of Incident, 2.1 Time of call, 3.2 Property Type", ", ")
    LastCol = ActiveSheet.UsedRange.Columns.Count
    For c = 1 To LastCol
        'If Cells(1, c) = "MyValueCheck" Then
        If (IsInArray(Cells(1, c), arr)) Then
            Cells(1, c).EntireColumn.Hidden = False
        Else
            Debug.Print "Hiding: " & Cells(1, c).Value
            Cells(1, c).EntireColumn.Hidden = True
        End If
    Next c
End Sub

Example-3:
'This code loops through & deletes all columns except column-headers written in the 'arr' array.
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub DeleteCols()
    Dim arr As Variant  'arr must Variant or String type as Range() & Split() return Sub-Strings (array).
    Dim LastRow As Long, LastCol As Integer, c As Integer, r As Long
    arr = Split("1.1 FRS Incident Number, 1.8 Station Ground of Incident, 2.1 Time of call, 3.2 Property Type, 4.3a X-Coordinate, 4.3b Y-Coordinate, 5.15 Cause/motive, Textual_Address, Fire Classification", ", ")
    For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
        If Not (IsInArray(Cells(1, c), arr)) Then
            Cells(1, c).EntireColumn.Delete
        End If
    Next c

End Sub


Sorting Array Elements in VBA

VBA has no built-in support for sorting the values stored in an array. One method that can be used to sort arrays is to put the data back on to a worksheet, sort the data on the worksheet, and then read back the values from the worksheet into the array. The second method for sorting arrays is to use any simple sort algorithm (such as Bubble sorting) to sort the array in place.
Method-1: Sorting by writing on Worksheet - sorting data then - read back into array:
Sub SortViaWorksheet()
    Dim arr() As String ' this is the array to be sorted
    Dim WS As Worksheet ' temporary worksheet
    Dim R As Range
    Dim N As Long
   
        ' populating array
    arr = Split("zzz, aaa, nnn, ppp, bbb", ", ")
    'Debug.Print Join(arr, "; ")
    Application.ScreenUpdating = False
   
    ' create a new sheet
    Set WS = ThisWorkbook.Worksheets.Add
   
    ' put the array values on the worksheet
    Set R = WS.Range("A1").Resize(UBound(arr) - LBound(arr) + 1, 1)
    R = Application.Transpose(arr)
   
    ' sort the range
    R.Sort key1:=R, order1:=xlAscending, MatchCase:=False
   
    ' load the worksheet values back into the array
    'Erase arr  'Erase purges all elements & resizes array to 0, hence ReDim/Split() will be required.
    For N = 1 To R.Rows.Count
        arr(N - 1) = R(N, 1) 'N-1 because index starts with 0.
    Next N
   
    ' delete the temporary sheet
    Application.DisplayAlerts = False
    WS.Delete
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
   
    ' test/debug/confirmation
    MsgBox Join(arr, ", ")
    For N = LBound(arr) To UBound(arr)
        Debug.Print arr(N)
    Next N
End Sub  

Method-2: Sorting using manual sort: (bubble sort or quick sort)
Bubble sort implementation:
'Two ways to call following BubbleSort() sub:
'     BubbleSort yourArrayName     or
'     Call BubbleSort(yourArrayName)
Sub BubbleSort(arr)
  Dim strTemp As String
  Dim i As Long
  Dim j As Long
  Dim lngMin As Long: lngMin = LBound(arr)
  Dim lngMax As Long: lngMax = UBound(arr) -1
  For i = lngMin To lngMax
    For j = i + 1 To lngMax
      If arr(i) > arr(j) Then    'for Descending order:      If arr(i) < arr(j) Then 
        strTemp = arr(i)
        arr(i) = arr(j)
        arr(j) = strTemp
      End If
    Next j
  Next i
End Sub

Quick sort implementation:
Sub QuickSort(arr, Lo As Long, Hi As Long)
  Dim varPivot As Variant
  Dim varTmp As Variant
  Dim tmpLow As Long
  Dim tmpHi As Long
  tmpLow = Lo
  tmpHi = Hi
  varPivot = arr((Lo + Hi) \ 2)
  Do While tmpLow <= tmpHi
    Do While arr(tmpLow) < varPivot And tmpLow < Hi
      tmpLow = tmpLow + 1
    Loop
    Do While varPivot < arr(tmpHi) And tmpHi > Lo
      tmpHi = tmpHi - 1
    Loop
    If tmpLow <= tmpHi Then
      varTmp = arr(tmpLow)
      arr(tmpLow) = arr(tmpHi)
      arr(tmpHi) = varTmp
      tmpLow = tmpLow + 1
      tmpHi = tmpHi - 1
    End If
  Loop
  If Lo < tmpHi Then QuickSort arr, Lo, tmpHi
  If tmpLow < Hi Then QuickSort arr, tmpLow, Hi
End Sub
Use above like this:
QuickSort MyArray, LBound(MyArray), UBound(MyArray)
or
Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))


Another Bubble sort example (for both Ascending & Descending orders):
Option Explicit
Sub SortArray()
Dim MyArray As Variant, i As Long
MyArray = Array(1, 4, 2, 32, 5, 21)
' True being sort as Ascending. False will sort Descending.
MyArray = BubbleSrt(MyArray, True)
For i = LBound(MyArray) To UBound(MyArray)
  MsgBox MyArray(i)
Next i
End Sub

Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
' True being sort as Ascending. False will sort Descending.
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
If Ascending = True Then
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If ArrayIn(i) > ArrayIn(j) Then
        SrtTemp = ArrayIn(j)
        ArrayIn(j) = ArrayIn(i)
        ArrayIn(i) = SrtTemp
      End If
    Next j
  Next i
Else
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If ArrayIn(i) < ArrayIn(j) Then
        SrtTemp = ArrayIn(j)
        ArrayIn(j) = ArrayIn(i)
        ArrayIn(i) = SrtTemp
      End If
    Next j
   Next i
End If
BubbleSrt = ArrayIn

End Function




Deleting empty columns

Example-1:
This code deletes all empty columns in ActiveSheet (only):
Sub DeleteEmptyColumns()
    'Application.ScreenUpdating = False  'Application can be omitted as object assumed in VBE
    ScreenUpdating = False
    'Debug.Print ActiveSheet.UsedRange.Columns.Count
    For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
        'Debug.Print WorksheetFunction.CountA(Columns(i))
        If WorksheetFunction.CountA(Columns(i)) = 0 Then
            Columns(i).Delete
        End If
    Next
    ScreenUpdating = True
End Sub

Example-2:
'This code loops through all sheets and deletes any empty columns:
Sub LoopingThroughSheets()
    Dim Text As String
    ScreenUpdating = False
    For Each Sheet In Worksheets
        Text = Text & Sheet.Name & vbNewLine
        Sheet.Select
        For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
            'Debug.Print WorksheetFunction.CountA(Columns(i))
            If WorksheetFunction.CountA(Columns(i)) = 0 Then
                Columns(i).Delete
            End If
        Next i
    Next Sheet
    ScreenUpdating = True
    MsgBox Text

End Sub


Counting a word in a column:

Sub CountBonfire()
    Dim lRow As Long            'last row (of table)
    Dim str1, str2 As String    'strings to search
    Dim cnt As Integer: cnt = 0 'count number of findings
   
    lRow = ActiveSheet.Range("GP" & ActiveSheet.Rows.Count).End(xlUp).Row     'MsgBox lRow

    str1 = "BONFIRE"
    str2 = UCase("Controlled burning")
    'str3 = UCase("")
   
    For Each cell In Range("AM1:AM" & lRow)
        'Set wcf = Range("d1").Find(cell.Value)
        'Above is ok if exact value matches in range - Not for <= or >= comparisons.
        If (InStr(UCase(cell.Value), str1)) <> 0 Or InStr(UCase(cell.Value), str2) <> 0 Then
            'MsgBox cell.Row '_ Exit For
            'MsgBox ActiveSheet.Range("GN" & cell.Row).Value
            'If (InStr(UCase(ActiveSheet.Range("GN" & cell.Row).Value), UCase("overborder"))) = 0 Then
                'Exit For
                cnt = cnt + 1
            'End If
        End If
    Next cell
    MsgBox cnt
End Sub

Finding a date in a range of dates:

Following VBA code takes the cursor (as Goto command) to the current week (Assumption: Worksheet contains a column listing weekly-dates (here A1:A300)).
Note: One of the easiest way to compare dates in VBA is to convert them into long values using CLng() function, see used in the example below.
Sub curr_week()
    Dim cell As Range, _
        wcf As Range
    Dim today As Long     'must compare dates in Long & Date+Time or just Time in Double otherwise problematic.
    today = CLng(Date)    'converting current date into Long.

    For Each cell In Range("A1:A300")
        'Set wcf = Range("d1").Find(cell.Value)
        'Above is ok if exact value matches in range - Not for <= or >= comparisons.
        If IsDate(cell.Value) And Not IsEmpty(cell.Value) Then
            If today >= CLng(cell.Value) And today < CLng(cell.Offset(1, 0).Value) Then
                Set wcf = cell
            End If
        End If
    Next cell
   
    If Not wcf Is Nothing Then
        Debug.Print wcf.Value       'Ctrl+G to open Immediate window where Debug-stmts print.
        Application.Goto wcf, True  'Application.Goto requires a range.
    Else
        MsgBox "Date range not found, Eddie to check Macro."
    End If
End Sub


Changing cell's background colour-shade to highlighting certain data (used in Data Analysis):

Method - 1: using Excel's Conditional Formatting ->  Data Bars / Icon Sets OR Colour Scales.
Colouring a range - using Interior.Color property:
Range("A1").Interior.Color = RGB(255, 0, 0)    'using RGB function
Range("A1").Interior.ColorIndex = 37               'using ColorIndex
Setting background color to 'No Fill':
Range("A1").Interior.ColorIndex = 0
Displaying ColorIndex
MsgBox Selection.Interior.ColorIndex

Method - 2: using VBA Code.
Sub HighlihgtCellsAsPerValue()
    Dim maxval As Integer, rng As Range, cell As Range
    Set rng = Range("e4:g16")   'SET is mandatory as we are assigning a reference (not literal value/LET).
    For Each cell In rng
        cell.Value = WorksheetFunction.RandBetween(100, 999) 'filling cells with random values for test.
    Next

    maxval = WorksheetFunction.Max(rng)
    'Debug.Print ((9 / 255) * maxval)
    For Each cell In rng
        'cell.Interior.Color = RGB(255, 255 - (cell.Value * 255 / maxval), 255 - (cell.Value * 255 / maxval))
                    'above makes colours too dark, even though logically more correct.
        cell.Interior.Color = RGB(255, 255 - (cell.Value * 80 / maxval), 255 - (cell.Value * 80 / maxval))
    Next
End Sub


Searching & highlighting matching values from two ranges (using Array from a Range):

Ver-1 Requires: two ranges in column B,  file: ArrayFromRange_RowHide.xlsm.
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub FindMatchingValsFromOtherRange()
    Dim rng, cell As Range: Set rng = Range("b1:b39")
    Dim arr() As Variant  'arr must Variant or String type as Range() & Split() return Sub-Strings (array).
    'arr() = Split("Essex, Berkshire, Dorset, Durham", ", ") 'manual array - without using range.
    arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).
    'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).
    'Application.SendKeys "^g ^g ^a {DEL} {F7}"  'Clearing Immediate/Debug-output window.
    Debug.Print Now
    'Debug.Print Join(arr, ", ")
    For Each cell In rng
        If (IsInArray(cell.Value, arr)) Then
            cell.Interior.Color = vbRed      'Highlight cell.
            'cell.EntireRow.Hidden = True  'Hide EntireRow.
        End If
    Next cell
End Sub


Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-2 Requires alteration in code below: define a range (38 cells) in column B, code then asks user to continue to hide rows. file: "CIPFA Stats 2014-15.xlsm".
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub HideOtherGroups()
    Dim rngAllStns, cell As Range
    Dim totArrElems As Integer: totArrElems = 0
    Dim arr As Variant
    Set rngAllStns = Range("b6:b43")
    rngAllStns.Select
    ContiExec = MsgBox("Are you happy with selected cells, continue hiding row?", vbOKCancel + vbQuestion)
    If ContiExec = vbCancel Then 'incorrect selection of cells - exit sub
        Exit Sub
    End If
    arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",") 'manual array - without using range.
    'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1
    'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).
    'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).
    'Application.SendKeys "^g ^g ^a {DEL} {F7}"  'Clears Immediate/Debug-output window.
    Debug.Print Now
    'Debug.Print Join(arr, ", ")
    rngAllStns.EntireRow.Hidden = True
    For Each cell In rngAllStns
        If (IsInArray(cell.Value, arr)) Then
            cell.EntireRow.Hidden = False
            totArrElems = totArrElems + 1
        End If
    Next cell
    MsgBox "Total count of visible rows: " & totArrElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count
End Sub

Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows, also now limited (500) row search, uses Goto() instead of Cells().  File: "CIPFA Stats 2014-15.xlsm".
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub HideOtherGroups()
'Search & hide all rows except matching values from a set of values (stored in an Array):
'Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows., file: "CIPFA Stats 2014-15.xlsm".
    Dim rngAllStns, cell As Range
    Dim totArrElems As Integer: totArrElems = 0
    Dim arr As Variant  'arr must Variant or String type as Range() & Split() return Sub-Strings (array).
    'Set rngAllStns = Range("b6:b43")  'reading source-data from sheet/range (instead of VBA code/array)
    'Cells(1, 2).Select  'OR  ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()
    Application.GoTo ActiveSheet.Range("B1"), True
    'MsgBox ActiveCell.Address
    Do While ActiveCell.Row < 500
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value = "Avon") Then
            Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(37, 0))  'Offset doesn't count current cell.
            Exit Do
        End If
    Loop
    rngAllStns.Select
    ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & "  - Continue hiding row?", vbYesNo + vbQuestion)
    If ContiExec = vbNo Then 'incorrect selection of cells - exit sub
        Exit Sub
    End If
    'Manually storing stations in array - not reading from range on sheet:
    arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",")
    'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1
    'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).
    'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).
    'Application.SendKeys "^g ^g ^a {DEL} {F7}"  'Clears Immediate/Debug-output window.
    Debug.Print Now
    'Debug.Print Join(arr, ", ")
    rngAllStns.EntireRow.Hidden = True
    For Each cell In rngAllStns
        If (IsInArray(cell.Value, arr)) Then
            cell.EntireRow.Hidden = False
            totArrElems = totArrElems + 1
        End If
    Next cell
    MsgBox "Total count of visible rows: " & totArrElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count
End Sub


Searching & hiding all rows except matching values from a set of values (stored in an Array):

Ver-4 Requires: searches for value set for variable 'FirstNameInRange' (such as"Avon") in column B, if not found exits gracefully, if found, auto-selects next 37 cells, then asks user to continue to hide rows, (search limited to 500 rows), uses Goto() instead of Cells(). Hides only unwanted rows (instead of hiding all rows first then unhide required).  File: "CIPFA Stats 2014-15.xlsm".
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub HideOtherGroups()
    Dim rngAllStns, cell As Range
    Dim FirstNameInRange As String: FirstNameInRange = "Avon"
    Dim ContiExec, visibleElems As Integer: visibleElems = 0
    Dim arr As Variant
    'Set rngAllStns = Range("b6:b43")  'reading source-data from sheet/range (instead of VBA code/array)
    'Cells(1, 2).Select  'OR  ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()
    Application.Goto ActiveSheet.Range("B1"), True
    'MsgBox ActiveCell.Address
    Do While ActiveCell.Row < 500
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value = FirstNameInRange) Then
            Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(46, 0))  'total-1: Offset doesn't count current cell.
            Exit Do
        End If
    Loop
    'If Not rngAllStns Is Nothing Then   'range not defined remains EMPTY (not null), hence check with isEmpty().
    If Not IsEmpty(rngAllStns) Then
        rngAllStns.Select
    Else
        MsgBox """" & FirstNameInRange & """" & " not found."
        Application.Goto ActiveSheet.Range("B1"), True
        Exit Sub
    End If
    ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & "  - Continue hiding row?", vbYesNo + vbQuestion)
    If ContiExec = vbNo Then 'incorrect selection of cells - exit sub
        Exit Sub
    End If
    'Manually storing stations in array - not reading from range on sheet:
    arr = Split("Bedfordshire,Berkshire,Buckinghamshire,Cambridgeshire,Dorset,Durham,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",")
    'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1
    'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).
    'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).
    'Application.SendKeys "^g ^g ^a {DEL} {F7}"  'Clears Immediate/Debug-output window.
    Debug.Print Now
    'Debug.Print Join(arr, ", ")
    'rngAllStns.EntireRow.Hidden = True  'hiding all rows in the range.
    For Each cell In rngAllStns
        If (IsInArray(cell.Value, arr)) Then
            'cell.EntireRow.Hidden = False
            visibleElems = visibleElems + 1
            Debug.Print visibleElems & ". " & cell.Value
        Else
            '.EntireRow.Delete 'when deleting rows from a range, run loop-steps from bottom to top, otherwise error: "row/object doesn't exist".
            cell.EntireRow.Hidden = True
        End If
    Next cell
    MsgBox "Total count of visible rows: " & visibleElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count
End Sub

Searching & deleting rows not containing certain values (stored in an Array):

Requires: searches for value set for variable 'FirstNameInRange' (such as"Avon") in column B, if not found exits gracefully, if found, auto-selects next 37 cells, then asks user to continue to delete rows (search limited to 500 rows), uses Goto() instead of Cells(). Deletes rows from bottom (row-by-row).  File: "CIPFA Stats 2014-15.xlsm".
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Sub DeleteRowsFromOtherGroups()
'Search & hide all rows except matching values from a set of values (stored in an Array):
'Ver-3 Requires: searches for "Avon" in column B, if found, auto-selects next 37 cells, then asks user to continue to hide rows., file: "CIPFA Stats 2014-15.xlsm".
    Dim rngAllStns As Range
    Dim Firstrow, Lastrow As Long
    Dim FirstNameInRange As String: FirstNameInRange = "England"
    Dim ContiExec, visibleElems As Integer: visibleElems = 0
    Dim arr As Variant
    'Set rngAllStns = Range("b6:b43")  'reading source-data from sheet/range (instead of VBA code/array)
    'Cells(1, 2).Select  'OR  ActiveSheet.Cells(1, 2).Select 'doesn't always activate/display the selection - unlike App.Goto()
    Application.Goto ActiveSheet.Range("B19"), True
    'MsgBox ActiveCell.Address
    Do While ActiveCell.Row < 500
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value = FirstNameInRange) Then
            Set rngAllStns = Range(ActiveCell, ActiveCell.Offset(46, 0))  'total-1: Offset doesn't count current cell.
            Exit Do
        End If
    Loop
    'If Not rngAllStns Is Nothing Then   'range not defined remains EMPTY (not null), hence check with isEmpty().
    If Not IsEmpty(rngAllStns) Then
        rngAllStns.Select
        Firstrow = rngAllStns.Cells(1).Row
        Lastrow = rngAllStns.Rows(rngAllStns.Rows.Count).Row
        'MsgBox Firstrow & "  -  " & Lastrow
    Else
        MsgBox """" & FirstNameInRange & """" & " not found."
        Exit Sub
    End If
    ContiExec = MsgBox("Are you happy with selected cells/rows: " & rngAllStns.Address & "  - Continue hiding row?", vbYesNo + vbQuestion)
    If ContiExec = vbNo Then 'incorrect selection of cells - exit sub
        Exit Sub
    End If
    arr = Split("Bedfordshire & Luton,Royal Berkshire,Buckinghamshire,Cambridgeshire,Dorset,County Durham & Darlington,East Sussex,Norfolk,Northamptonshire,Oxfordshire,Suffolk,West Sussex,Wiltshire", ",") 'manual array - without using range.
    'MsgBox Join(arr, ", ") & vbCrLf & vbCrLf & vbCrLf & "Total: " & UBound(arr) + 1
    'arr = Range("B44:B56") 'Note: Range() always returns 2-D array (even if data is in single row/col).
    'MsgBox arr(0, 0) 'Error: Subscript out of range as index in VBA starts with 1 (not 0 Ggrrr).
    'Application.SendKeys "^g ^g ^a {DEL} {F7}"  'Clears Immediate/Debug-output window.
    Debug.Print Now
    'Debug.Print Join(arr, ", ")
    'rngAllStns.EntireRow.Hidden = True
    'For Each cell In rngAllStns
    For Lrow = Lastrow To Firstrow Step -1
      With Cells(Lrow, "B")
        If (IsInArray(.Value, arr)) Then
            'cell.EntireRow.Hidden = False
            visibleElems = visibleElems + 1
            Debug.Print visibleElems & ". " & .Value
        Else
            .EntireRow.Delete   'when deleting rows from a range, run loop-steps from bottom to top, otherwise error: "row/object doesn't exist".
            '.EntireRow.Hidden = True
        End If
      End With
    Next Lrow
    MsgBox "Total count of visible rows: " & visibleElems & vbCrLf & vbCrLf & "Out of total: " & rngAllStns.Rows.Count
End Sub


Simple Cut-Copy-Paste using VBA:

Following 1 liner copies a Range within same Sheet (to a specified destination):
   Range("A1:D4").Copy(Range("E5"))

Following 1 liner copies a Range from Sheet1 to Sheet2 (at specified destination):
   Worksheets("Sheet1").Range("A1:D4").Copy destination:=Worksheets("Sheet2").Range("E5")

Following code is generated by Macro recording that copies 1st row from Sheet1 to Sheet2:
Sub CopyRow()    Worksheets("Sheet1").Rows(1).Copy    Worksheets("Sheet2").Select    Worksheets("Sheet2").Rows(1).Select    Worksheets("Sheet2").PasteEnd Sub
 
Following code is hand written to skip blanks (Skip-Blanks including empty strings ""). Following checks for empty strings then copies a range:
Sub LoopingRows()    Dim NewRow, LastRow As Long, r As Long: NewRow = 1    Sheets("Sheet3").Select    LastRow = Cells(Rows.Count, 1).End(xlUp).Row    For r = 1 To LastRow        'If Cells(r, 1) > 0 Then        Debug.Print Len(Cells(r, 1))        If Len(Cells(r, 1)) > 0 Then            Range("A" & r & ":B" & r).Copy Range("D" & NewRow)            NewRow = NewRow + 1        End If'        If r > 500 Then'            Exit For'        End If    Next rEnd Sub
 
'Following code asks confirmation, if user clicks Yes, Cuts the current row, and Pastes the row into specified sheet (here: "Completed Inc.").
Sub MoveRowFromIncompleteToCompleteSheet()
    sh = ActiveSheet.Name
    r = ActiveCell.Row
    ans = MsgBox("Would you like to move current row to the ""Completed Inc."" sheet?", vbYesNo, "Move Row!")
    If ans = vbYes Then
        ActiveCell.EntireRow.Cut _
        Destination:=Sheets("Completed Inc.").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        MsgBox "Row number: " & r & " has been moved to ""Completed Inc."" sheet"
        Sheets(sh).Rows(r).EntireRow.Delete
    End If
End Sub

Tirnary Operator in VBA

There is no ternary operator ( x = <condition> ? 1 : 2 ) in VBA, however if you really would like to write ternary operator you can use the IIF() ternary consional function in VBA. E.g.:
IIf(expr, truepart, falsepart)
function, x = IIf(<condition>, 1, 2), which reduces the verbosity of code.
----------------------------------------------------------------------------------------------

Word VBA Samples:


VBA Code 1: Remove all hyperlinks of current document


Sub RemoveHyperlinks()
      With ThisDocument
             'Loop while there are hyperlinks on document
             While .Hyperlinks.Count > 0
                   .Hyperlinks(1).Delete
             Wend
      End With
      'Turn off auto-hyperlinking:
      Application.Options.AutoFormatAsYouTypeReplaceHyperlinks = False
End Sub

VAB code 2: Remove all hyperlinks in all open documents

Sub RemoveHyperlinksInAllOpenDocuments()

      ' Removes all hyperlinks from any open documents
      Dim doc As Document
      Dim szOpenDocName As String
      'Loop through all open documents:
      For Each doc In Application.Documents
             'Store the document name
             szOpenDocName = doc.Name
             'Remove the hyperlinks from that document
             With Documents(szOpenDocName)
                   'Loop while there are hyperlinks afoot!
                   While .Hyperlinks.Count > 0
                                .Hyperlinks(1).Delete
                   Wend
             End With
             'Turn off auto-hyperlinking:
             Application.Options.AutoFormatAsYouTypeReplaceHyperlinks = False
      Next doc
End Sub



File Handling (Word-VBA)

Private Sub WriteToFile_Click()
    'Open file in file-system: (creates new file if doesn't exist)
    Open "C:\Temp\HoldPastes.txt" For Append As #1
   
    'Read Clipboard content:
    Dim myData As DataObject
    Dim strClip As String
    Set myData = New DataObject
    myData.GetFromClipboard
    strClip = myData.GetText
   
    'Paste Clipboard content in the same file:
    Selection.EndKey Unit:=wdStory, Extend:=wdMove
    Selection.PasteSpecial DataType:=wdPasteText
   
    'Write to file:
    Write #1, "------------------------" & vbCrLf & vbCrLf & vbCrLf
    Write #1, strClip
   
    'Close file:
    Close #1
End Sub


Private Sub ReadWriteFile_Click()
   Dim sFirst, sLast, sAddress, sCity, sState, sZip As String
   ' CREATE DATA FILE
   ' Open file in current directory:
   Open "Datafile.txt" For Output As #1
   ' Write data to file.
   Write #1, "John", "Doe", "An Address", "A City", "A State", "A Zip"
   ' Close File.
   Close #1
   ' RETRIEVE DATA FROM FILE
   ' Open file for input.
   Open "Datafile.txt" For Input As #1
   ' Loop until the end of file is reached.
   Do While Not EOF(1)
      ' Read data into variables.
      Input #1, sFirst, sLast, sAddress, sCity, sState, sZip
      ' Print data to Debug window.
      Debug.Print sFirst, sLast, sAddress, sCity, sState, sZip
   Loop
   ' Close file.
   Close #1
End Sub

Replacing Dodgy Characters
Converts Text-Paragraphs Into Html-Lists

Sub ConvertIntoHtmlParas()
    'This macro first deletes all blank lines then encloses all the paragraphs in a document with <p></p> (except paragraphs enclosed within <li></li>),
    'Secondly this also replaces all special (dodgy) characters with plain characters.
    Dim pCount As Integer
    Dim paraCount As Integer
    pCount = ActiveDocument.Paragraphs.Count
    Selection.HomeKey Unit:=wdStory
    For x = 1 To (pCount + 1)
        Selection.MoveEnd Unit:=wdParagraph, Count:=1
        If Len(Trim(Replace(Selection.Text, vbCr, ""))) < 1 Then  ' Note: in MS-Word a new-line character is vbCr (NOT vbCrLf).
            Selection.Delete
        End If
        Selection.EndOf (wdParagraph)
    Next
    Selection.EndKey Unit:=wdStory
    Selection.TypeText (vbCrLf)
    Selection.HomeKey Unit:=wdStory
    paraCount = ActiveDocument.Paragraphs.Count
    For x = 2 To paraCount 'Starting from 2 (instead of 1) to skip last blank paragraph that was manually entered for consistency.
        Selection.StartOf (wdParagraph)
        Selection.MoveEnd Unit:=wdParagraph, Count:=1
        If (InStr(1, Trim(Selection.Text), "<li>", vbTextCompare) = 0) Then
            Selection.StartOf (wdParagraph)
            Selection.TypeText ("<p>")
            Selection.EndOf (wdParagraph)
            Selection.MoveLeft Unit:=wdCharacter, Count:=1
            Selection.TypeText ("</p>")
            Selection.MoveDown Unit:=wdLine, Count:=1
        Else
            Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
        End If
    Next
    'Following section replaces dodgy characters: (¦`’‘“”– " ")
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "¦"
        .Replacement.Text = "|"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
       
        .Text = "‘"    ' tr.Text.Replace(ChrW(8216), Chr(39))
        .Replacement.Text = "'"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
       
        .Text = "’"    ' tr.Text.Replace(ChrW(8217), Chr(39))
        .Replacement.Text = "'"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
       
        .Text = ChrW(8220)
        .Replacement.Text = """"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
       
        .Text = ChrW(8221)
        .Replacement.Text = """"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
       
        .Text = "–"
        .Replacement.Text = "-"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
End Sub

'Following Word-VBA Sub Converts Text-Paragraphs Into Html-Lists
Sub convertIntoHtmlLists()
  'This macro encloses selected paragraphs within <li></li>, deleting all blank lines.
  Dim pCount As Integer
  pCount = ActiveDocument.Paragraphs.count
  Selection.EndKey Unit:=wdStory
  Selection.TypeText (vbCrLf)
  Selection.HomeKey Unit:=wdStory
  For x = 1 To pCount
  Selection.MoveEnd Unit:=wdParagraph, count:=1
  If Len(Trim(Selection.Text)) <= 1 Then
      'If (str = vbCr Or str = vbCr Or str = vbCrLf) Then  MsgBox "It is CRLF" End If
      Selection.Delete
  Else
      Selection.StartOf (wdParagraph)
      Selection.TypeText ("<li>")
      Selection.EndOf (wdParagraph)
      Selection.MoveLeft Unit:=wdCharacter, count:=1
      Selection.TypeText ("</li>")
      Selection.MoveRight Unit:=wdCharacter, count:=1
  End If
  Next
End Sub


Sub convertIntoHtmlParas_OLD()
  'This macro encloses all the paragraphs in a document with <p></p> (In new separate lines), deleting all blank lines,
  'it excludes paragraphs enclosed within <li></li> see next script.
  Dim pCount As Integer
  pCount = ActiveDocument.Paragraphs.count
  Selection.EndKey unit:=wdStory
  Selection.TypeText (vbCrLf)
  Selection.HomeKey unit:=wdStory
  For x = 1 To pCount
  Selection.MoveEnd unit:=wdParagraph, count:=1
  If Len(Trim(Selection.Text)) <= 1 Then
      Selection.Delete
  ElseIf (InStr(1, Trim(Selection.Text), "<li>", vbTextCompare) <= 0) Then
      Selection.StartOf (wdParagraph)
      Selection.TypeText ("<p>")
      Selection.TypeText (vbCrLf)
      Selection.MoveDown unit:=wdLine, count:=1
      Selection.EndOf (wdParagraph)
      Selection.TypeText ("</p>")
      Selection.TypeText (vbCrLf)
  Else
      Selection.MoveRight unit:=wdCharacter, count:=1, Extend:=wdMove
  End If
  Next
End Sub



ProperCase by macro

Sub Caps1stChar()
    'This will convert the case of the first letter of selection into uppercase.
    Dim txt As String
    txt = ""
    For i = 1 To Selection.Words.Count
        txt = txt & StrConv(Selection.Words(i), vbProperCase)
    Next i
    Selection.Text = txt
End Sub

ProperCase with 1st character bold (Ver-1):

e.g. Propercase With 1st Character Bold:
'Ver1: Doesn't excludes anything, applies to all text including: punctuations, numbers and words such as 'of' & 'for'.
Sub BoldCaps1stChar()
    Dim cnt As Integer
    cnt = Selection.Words.Count
   
    'move (without wdExtend) cursor to the left/beginning of the selection:
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    'running a loop to select the 1st character then highlight it:
    For i = 1 To cnt
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Selection.Font.Bold = wdToggle
        Selection.Range.Case = wdUpperCase
        Selection.MoveRight Unit:=wdWord, Count:=1
    Next i
End Sub

ProperCase with 1st character bold (Ver-2):

'Ver2: Excludes all non-alphabets
Sub BoldCaps1stAlphas()
    Dim cnt As Integer: cnt = Selection.Words.Count
    Dim regEx As New RegExp
    'requires: VBA reference to "Microsoft VBScript Regular Expressions 5.5" (under: VBE -> Tools -> References)
    regEx.Pattern = "[a-zA-Z]"
   
    'move (without wdExtend) cursor to the left/beginning of the selection:
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    'running a loop to select the 1st character then highlight it:
    For i = 1 To cnt
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        'MsgBox Left(Selection, 1)
        'If (Selection = "," Or Selection = Chr(34) Or Selection = (Chr(34) & ",")) Then GoTo EndLoop End If
        If regEx.Test(Left(Selection, 1)) Then
            Selection.Font.Bold = wdToggle
            Selection.Range.Case = wdUpperCase
        End If
        Selection.MoveRight Unit:=wdWord, Count:=1
        'EndLoop:
    Next i
End Sub

ProperCase with 1st character bold (Ver-3):

'Ver3: (EdChoice) Excludes all non-alphabets & certain words such as 'and', 'of' & 'for'.
Sub BoldCaps1stAlphas()
    Dim cnt As Integer: cnt = Selection.Words.Count
    Dim regEx As New RegExp
    regEx.Pattern = "[a-zA-Z]"
   
    'move (without wdExtend) cursor to the left/beginning of the selection:
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    'running a loop to select the 1st character then highlight it:
    'For Each w In Selection.Words  'this won't work here as we need to alter the Words in selection.
    For i = 1 To cnt
        Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend  'select single word
        'MsgBox (Selection)  'check which word
        'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))
        'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.
        If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0) Then
            Selection.MoveRight Unit:=wdWord, Count:=1
            GoTo NextIteration
        End If
        Selection.MoveLeft Unit:=wdWord, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        'check if selected character is an alphabet:
        If (regEx.Test(Selection)) Then
            Selection.Font.Bold = wdToggle
            Selection.Range.Case = wdUpperCase
        End If
        Selection.MoveRight Unit:=wdWord, Count:=1
NextIteration:
    Next i
End Sub

ProperCase with 1st character bold (Ver-4):

'Ver4: (EdChoice) Excludes all non-alphabets & certain words (stored in Array elements - makes long if statement redundant.
Sub Highlight1stCharacter()
    Dim cnt As Integer: cnt = Selection.Words.Count
    Dim regEx As New RegExp
    regEx.Pattern = "[a-zA-Z]"  'requires: VBE>Tools>Reference: "Microsoft VBScript Regular Expressions 5.5".
   
    Dim excl() As String
    excl() = Split("and, of, for, to, with, in, on, a, an, the", ", ")  'One-liner array assignment.

    'move (without wdExtend) cursor to the left/beginning of the selection:
    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    'running a loop to select the 1st character then highlight it:
    'For Each w In Selection.Words  'this won't work here as we need to alter the Words in selection.
    For i = 1 To cnt
        Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend  'select single word
        'MsgBox (Selection)  'check which word
        'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))
        'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.
        For Each x In excl
           If (InStr(Selection, x & " ") > 0) Then
               Selection.MoveRight Unit:=wdWord, Count:=1
               GoTo NextIteration
           End If
        Next x
        'above array-iteration replaces need of following Loooooong if statement:
            'If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0 Or InStr(Selection, "to ") > 0) Then
           
        Selection.MoveLeft Unit:=wdWord, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        'check if selected character is an alphabet:
        If (regEx.Test(Selection)) Then
            Selection.Font.Bold = wdToggle
            Selection.Range.Case = wdUpperCase
        End If
        Selection.MoveRight Unit:=wdWord, Count:=1
NextIteration:
    Next i
End Sub



------------ x -------------



Posted by at No comments:
Subscribe to: Posts (Atom)