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.

Spreadsheet View

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 $A1ドル, 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

• Nahuatl: Sweet! I've never seen the IIF function. Also, I'd no idea you build a SpeedBoost on it's own procedure! But Most important of all, it's the Like statement. Thank you so much, once again Thomas. I'll go ahead and update my code, and post the answer to Super User. I'll make sure to add this and the other question as references.
• Nahuatl: You know what I'm having a hard time understanding; Target.Offset(0, 1).Value = data doesn't execute until after the loop. Does that mean that Excel holds all of those items in memory?
• Nahuatl: Ok, WOW! I just got it. data = Target.Value is the second array! That's genius. Do you know how many different projects I can go back to and add this to? That right there is game changing for me.

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.

• Nahuatl: Thank you! The GoTo was kinda of a last resort as I kept running into errors while trying to search. That solves that. Correct, and I thought about that when working through the code; I considered looking for numbers, letters and periods, but from the examples given, it didn't make sense to do so. Also, there is always only one occurrence per string. Upon posting the answer, I'll make sure to make note of that.

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 '??.??.???.???`

• Nahuatl: Hi R. Roe! Your answer is definitely shorter and probably a lot easier to understand. However, a similar answer already existed in the question both using Regex functions and regular excel functions (similar to your mid function). The idea behind the code above was to take a different approach (hence the "without changing the logic" part.