trjhtr

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

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

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.

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