Excel VBA Retrieving a Specific Pattern from String

Question

The following VBA code is in response to a SuperUser question which I found interesting.

What I'm looking for in a response?

• Code cleanliness. Can I do more to make the code easier to read and potentially debug in the future?
• Code reduction. Is there anything else I can do, without changing the logic, to reduce the amount of code written?
• The use of variants in code. I've noticed that the use of variants is frowned upon and with good reason. The memory needed for variants seems to be substantially larger than any other data type.
• Use of modules. I've found that it's difficult for me to use modules as opposed to hosting the code within the Sheet or ThisWorkbook. Any comments on the use of modules?

Below is a screen shot of how my spreadsheet looks:

• In the original question, the user is only asking to scrub 5 records. I duplicated them until I had 5K records. Completion time was 0.66 seconds. Speed doesn't seem like much of a concern in this case.

Below is the code. FYI, this is located in Sheet1:

Sub PatternScrub()

Dim targetRange As Range
Set targetRange = Range("A1", Range("A1").End(xlDown))

Dim Pattern As String
Dim x As Integer

' TO IMPROVE PERFORMANCE

With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .EnableEvents = False
End With

' MAIN SCRUB
For Each cell In targetRange

    Pattern = Pattering(cell.Value)

    x = PatternIndex(Pattern)

    If x = 0 Then
        GoTo NextIteration
    Else
        cell.Offset(0, 1).Value = Mid(cell.Value, x, 13)
    End If

NextIteration:

Next cell

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .EnableEvents = True
End With

End Sub

Private Function Pattering(ByVal target As String) As String

' TURNS THE STRING INTO 1s AND 0s

Dim i As Integer

For i = 1 To Len(target)

   If Mid(target, i, 1) = "." Then
        Mid(target, i, 1) = 0
    Else
        Mid(target, i, 1) = 1
   End If

Next

Pattering = target

End Function

Private Function PatternIndex(ByVal Pattern As String) As Integer

' MATCHES THE PATTERN AND RETURNS THE FIRST INDEX

    On Error GoTo ErrorHandler

    PatternIndex = Application.WorksheetFunction.Search("1101101110111", Pattern)

ErrorHandler:

    Select Case Err.Number
        Case 1004
            PatternIndex = 0
    End Select

End Function

Answer 1

Code Reduction

When a subroutine performs multiple tasks you should consider extracting each task into a separate subroutine. This will allow improve readability and make debugging easier by allowing you to focus on each tasks independently.

For example, extracting the code used for speed boosting from PatternScrub() into its own subroutine will reduce PatternScrub() from 42 to 32 lines of code. This will allow you to view the entire method without scrolling.

Sub SpeedBoost(TurnOn As Boolean)
    With Application
        .Calculation = IIf(TurnOn, xlCalculationManual, xlCalculationAutomatic)
        .ScreenUpdating = Not TurnOn
        .DisplayStatusBar = Not TurnOn
        .EnableEvents = Not TurnOn
    End With
End Sub

The code for extracting the pattern value should also be extracted into its own function. In this way, you can test the return value without running the main subroutine.

Private Function getPatternValue(Text As String) As String
    Dim x As Long
    x = PatternIndex(Text)
    If x > 0 Then getPatternValue= Mid(Text, x, 13)
End Function

The Iff function can be used to replace an If statement where 1 of 2 values will be assigned. Although, not as efficient as an If statement, you will save 4 lines of code.

Mid(target, i, 1) = IIf(Mid(target, i, 1) = ".", 0, 1)

Although the PatternIndex Error Handler is probably considered the best practice; On Error Resume Next will always give you the same result (in this case).

Private Function PatternIndex(ByVal Pattern As String) As Integer

' MATCHES THE PATTERN AND RETURNS THE FIRST INDEX
    On Error Resume Next
    PatternIndex = Application.WorksheetFunction.Search("1101101110111", Pattern)

End Function

Public Modules

The key to using Public Modules is to always fully qualify your Objects. Using With statements to do so will make your code more readable.

With ThisWorkbook.Worksheets("Sheet1")
    Set targetRange = .Range("A1", .Range("A1").End(xlDown))
End With

Note: You should take a bottom up approach to defining dynamic ranges. If Column A was empty the code above would reference $A:$A that 1,048,576 cells, whereas, the code below would reference $A$1, 1 cell.

With ThisWorkbook.Worksheets("Sheet1")
    Set targetRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With

More Stuff

The Like operator should be used to test if the pattern exists before processing the cell.

For Each cell In targetRange

    If cell.Value Like "*##.##.###.###*" Then
        Pattern = Pattering(cell.Value)
        x = PatternIndex(Pattern)
        cell.Offset(0, 1).Value = Mid(cell.Value, x, 13)
    End If

Next cell

Working with arrays will speed up the code considerably. The Refactored Code demonstrates an easy way to do so.

Refactored Code

Sub PatternScrub()
    Dim Pattern As String
    Dim x As Integer
    Dim data As Variant
    Dim Target As Range

    With ThisWorkbook.Worksheets("Sheet1")
        Set Target = Range("A1", Range("A1").End(xlDown))
    End With

    data = Target.Value

    SpeedBoost True                                   ' TO IMPROVE PERFORMANCE

    For x = 1 To UBound(data)                         ' MAIN SCRUB

        If data(x, 1) Like "*##.##.###.###*" Then
            data(x, 1) = getPatternValue(CStr(data(x, 1)))
        End If

    Next

    Target.Offset(0, 1).Value = data

    SpeedBoost False
End Sub

Private Function Pattering(ByVal Target As String) As String
    Dim i As Integer

    For i = 1 To Len(Target)

        Mid(Target, i, 1) = IIf(Mid(Target, i, 1) = ".", 0, 1) ' TURNS THE STRING INTO 1s AND 0s

    Next

    Pattering = Target

End Function

Private Function PatternIndex(ByVal Pattern As String) As Integer

    On Error Resume Next
    PatternIndex = Application.WorksheetFunction.Search("1101101110111", Pattern) ' MATCHES THE PATTERN AND RETURNS THE FIRST INDEX

End Function

Private Function getPatternValue(Text As String) As String
    Dim x As Long
    x = PatternIndex(Text)
    If x > 0 Then getPatternValue = Mid(Text, x, 13)
End Function

Sub SpeedBoost(TurnOn As Boolean)
    With Application
        .Calculation = IIf(TurnOn, xlCalculationManual, xlCalculationAutomatic)
        .ScreenUpdating = Not TurnOn
        .DisplayStatusBar = Not TurnOn
        .EnableEvents = Not TurnOn
    End With
End Sub

Answer 2

You can remove a goto - unconditional branches are strongly discouraged and in this case the code fall-through renders it unnecessary.

    If x = 0 Then
        GoTo NextIteration
    Else
        cell.Offset(0, 1).Value = Mid(cell.Value, x, 13)
    End If

NextIteration:

becomes

If x <> 0 Then cell.Offset(0, 1).Value = Mid(cell.Value, x, 13)

This code only works for a specific (hard coded) pattern without any variations. Your example (test case) focuses on numbers, but your pattern also matches aa.bb.ccc.ddd.

Answer 3

This is just an FYI to maybe get people to look at things a little different.

@Nahuatl_19650 all these answers are great but if you're trying to find a pattern there is a lot simpler way to do it. I made this with a user defined function (UDF) but you could add it to a sub or where ever needed.

Function StripIPAddress(myString As String) As String

    For i = 1 To Len(myString)
        If Mid(myString, i, 13) Like "??.??.???.???" Then
            StripIPAddress = Mid(myString, i, 13)
            Exit For
        End If
    Next

End Function

Then call it in your worksheet like this:

=StripIPAddress(A1)

All this is doing is looping across the string and looking for the specific patern '??.??.???.???`