Excel VBA Using Regex on Entire Spreadsheet

My Problem

I recently solved a problem I have been working on in VBA and I made a lot of useful discoveries for processing large spreadsheets of data.

I wanted to pull out all unique 9 to 14 digit numbers from the active worksheet and place them in the clipboard.

Accomplishing this goal by just looping through all the cell values was only practical for up to 100 thousand or so rows of data. I needed a much more efficient process to quickly finish on 1 million+ rows of data. Here's all the steps I took to solve the problem.

Regex in VBA

The most powerful tool we have for this solution is to utilize Regex to pull out all the numbers from our values in Excel. Here is a step by step guide on how to implement this:

Create a vbscript Regex object

Dim myRegExp As ObjectSet myRegExp = CreateObject(“vbscript.regexp”)

Define settings for your object

myRegExp.IgnoreCase = False
myRegExp.Global = True
myRegExp.Pattern = “([0-9]{9,14})”

Use the Execute method on your text to pull out matches

Dim sText As String
Dim Match As Object
Dim Matches As Variant
sText = “ < < all your text here > > “
Set Matches = myRegExp.Execute(sText)

Matches is now a collection of Strings that we have to loop through to store in a more useful array

ReDim newArray(0 To Matches.Count) As String
Dim i As Long
For i = 0 To Matches.Count - 1
    newArray(i) = Matches(i).Value
Next

Make a Function out of these steps

Function RegMatches(yourString As String, regex As String)
    Dim myRegExp As Object
    Dim Match As Object
    Dim Matches As Variant
    Dim matchCount As Long
    Set myRegExp = CreateObject(“vbscript.regexp”)
    myRegExp.IgnoreCase = False
    myRegExp.Global = True
    myRegExp.Pattern = regex
    Set Matches = myRegExp.Execute(yourString)
    matchCount = Matches.Count
    ReDim newArray(0 To matchCount - 1) As String
    Dim i As Long
    For i = 0 To matchCount - 1
        newArray(i) = Matches(i).Value
    Next
    RegMatches = newArray
End Function

The challenge now is getting all the text out of your spreadsheet that you want to run the REGEX against. I developed a quick way to pull out all the text in a spreadsheet without looping through every single cell.

Entire Sheet to String Function

Store an entire column in a one dimensional array

Function ColToString(yourSheet, col) As String
    Dim lastRow As Long
    lastRow = yourSheet.Range(“A1:A2”, yourSheet.UsedRange).Rows.Count
    Dim aC As Variant
    aC = Application.WorksheetFunction.Transpose(yourSheet.Range(Cells(1,col), Cells(lastRow, col)))
    colToString = Join(aC, “ “)
End Function

Loop through all your columns adding each one to your string

Function SheetToString(yourSheet) As String
    Dim lastCol As Integer
    lastCol = yourSheet.Range(“A1:A2”, yourSheet.UsedRange).Columns.Count
    For col = 1 To lastCol
        newString = newString & ColToString(yourSheet, col)
    Next col
    SheetToString = newString
End Function

Copy String to Clipboard Sub

This one is a little tricky to use. You have to go to the Tools - References… menu in VBA and check off “Microsoft Forms 2.0 Object Library” in order for this Sub to work.

Function CopyStringToClipboard(yourString As String)
    If yourString = “” Then Exit Sub
    Dim copiedText As DataObject
    Set copiedText = New MSForms.DataObject
    copiedText.SetText yourString
    copiedText.PutInClipboard
End Sub

Remove Duplicates from 1 Dimensional Array Function

Function Deduped1dArray(ByRef yourArray)
    Dim tempArray() As String
    ReDim tempArray(0)
    Dim lYourUbound As Long
    lYourUbound = UBound(yourArray)
    Dim l As Long
    For l = LBound(youArray) To lYourUbound
        If UBound(Filter(tempArray, yourArray(l))) = -1 Then
            tempArray(UBound(tempArray)) = yourArray(l)
            If UBound(tempArray) + 1 <= lYourUbound Then
                ReDim Preserve tempArray(UBound(tempArray) + 1)
            End If
        End If
    Next l
    Deduped1dArray = tempArray
End Function

Put It All Together

Now we can use these functions to easily make a Sub to pull out what we want.

Sub PullOutNumbers()
    If ActiveSheet Is Nothing Then Exit Sub
    Dim newString As String
    Dim sText As String
    Dim newArray() As String
    sText = SheetToString(ActiveSheet)
    newArray = RegMatches(sText, “([0-9]{9,14})”)
    newArray = Deduped1dArray(newArray)
    newString = Join(newArray, Chr(13))
    CopyStringToClipboard newString
    MsgBox UBound(newArray) & “ numbers added to your clipboard.”
End Sub