Loop through column and check if cell contains specific chars

Question

I'm in need of help trying to figure if Instr function will do this trick.
In a cell i have some text and numbers (ex: Overlay 700 MHz - 06_469)
See the final numbers? 2 numbers followed by _ (underscore) or any letter and then 3 more numbers.

Is there any way of searching for this in a specific column and if found, copy only these specific combination? NOTE: it can be anywhere in the cell, in beginning, end, middle, etc.....

Answer 1

Edit - Using Regular expressions for generic match, solution to clarified problem.

Using Regular Expressions (RegExp) to match the pattern "2 digits, 1 non-digit, 3 digits". You will need to add the Regex reference. In the VBA editor, go to Tools>References and tick

Microsoft VBScript Regular Expressions 5.5 

Then add the following function to your module:

Function RegexMatch(Myrange As Range) As String
    RegexMatch = ""

    Dim strPattern As String: strPattern = "[0-9]{2}[a-zA-Z_\-]{1}[0-9]{3}"
    Dim regEx As New RegExp
    Dim strInput As String
    strInput = Myrange.Value

    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With

    If regEx.Test(strInput) Then
        RegexMatch = regEx.Execute(strInput)(0)
    End If
End Function

And use it like so:

Dim myCell As Range
Dim matchString As String
For Each myCell In Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)
    matchString = RegexMatch(myCell)
    ' Copy matched value to another column
    myCell.Offset(0, 1).Value = matchString
Next myCell

Results:

For more on VBA RegExp, see this SO question:

How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops

---

Original - using Instr for search string match.

You're right, the Instr function is what you want, it returns 0 if the string isn't in the string and the index greater than 0 otherwise.

Dim myString as String
myString = "Overlay 700 MHz - 06_469"
Dim myDigitString as String
' Use RIGHT to get the last 6 characters (your search string)
myDigitString = Right(myString, 6)

Dim myCell as Range
' Cycle through cells in column A, which are also in the sheet's used range
For each myCell in Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)

    If Instr(myCell.Value, myDigitString) > 0 Then

        ' Copy cell to another sheet
        myCell.copy Desination:=ActiveWorkbook.Sheets("PasteToThisSheet").Range("A1")

        ' If you only want to get the first instance then...
        Exit For

    End If

Next myCell

To match the pattern "2 digits, another character, 3 digits" you could use:

For each myCell in Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)

    ' Check that first 2 digits and last 3 digits are in cell value
    ' Also check that they are separated by 1 character
    If Instr(myCell.Value, Left(myDigitString,2)) > 0 And _
       Instr(myCell.Value, Right(myDigitString,3)) > 0 And
       Instr(myCell.Value, Right(myDigitString,3)) - Instr(myCell.Value, Left(myDigitString,2)) = 3 Then

        ' Copy cell to another sheet
        myCell.copy Desination:=ActiveWorkbook.Sheets("PasteToThisSheet").Range("A1")

        ' If you only want to get the first instance then...
        Exit For

    End If

Next myCell

Answer 2

Use [regex] to look for a 'two number-underscore-three number' pattern.

Option Explicit

Sub pullSerialNumbers()
    Dim n As Long, strs() As Variant, nums() As Variant
    Dim rng As Range, ws As Worksheet
    Dim rgx As Object, cmat As Object

    Set rgx = CreateObject("VBScript.RegExp")
    Set cmat = Nothing
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ReDim Preserve nums(0)

    With ws
        strs = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
    End With

    With rgx
        .Global = True
        .MultiLine = True
        .Pattern = "[0-9]{2}\_[0-9]{3}"
        For n = LBound(strs, 1) To UBound(strs, 1)
            If .Test(strs(n, 1)) Then
                Set cmat = .Execute(strs(n, 1))
                'resize the nums array to accept the matches
                ReDim Preserve nums(UBound(nums) + 1)
                'populate the nums array with the match
                nums(UBound(nums) - 1) = cmat.Item(cmat.Count - 1)
            End If
        Next n
        ReDim Preserve nums(UBound(nums) - 1)
    End With

    With ws
        .Cells(2, "C").Resize(.Rows.Count - 1).Clear
        .Cells(2, "C").Resize(UBound(nums) + 1, 1) = _
            Application.Transpose(nums)
    End With

End Sub

This assumes that only one match could be found in any one cell. If there could be more then loop through the matches and add each one.

Answer 3

With data in column D:

Sub marine()
    Dim r As Range

    For Each r In Intersect(Range("D:D"), ActiveSheet.UsedRange)
        s = r.Value
        If s <> "" And InStr(s, "_") <> 0 Then
            ary = Split(s, "_")
            r.Offset(0, 1).Value = Right(ary(0), 2) & "_" & Left(ary(1), 3)
            End If
    Next r
End Sub

There are several issues with this approach:

• an underscore at the beginning or end of the text
• more than one underscore in the string
• an underscore surrounded with letters.