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.....
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
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:
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.
