Option Explicit

'-- Grove_DigitsID  http://www.mvps.org/dmcritchie/excel/code/digitisid.txt
'--                 http://www.mvps.org/dmcritchie/excel/digitisid.htm
'Harlan Grove posted a series of Functions for extracting words composed
'  of digits and words composed of digits and dashes  on 2003-10-20

'---/////  Harlan Grove -- possibly these should be split out  --begin--///
Function DigitsDashesAll(ByVal s As String) As String
 'Harlan Grove, worksheet.functions, 2003-10-20
 'concatenate all digits and dashes found in a string
 Dim i As Long, n As Long
 n = Len(s)
 For i = 1 To n
  If Mid(s, i, 1) Like "[!-0-9]" Then Mid(s, i, 1) = " "
 Next i
 DigitsDashesAll = Application.WorksheetFunction.Substitute(s, " ", "")
End Function
Function RemoveDigitsAll(ByVal s As String) As String
 'based on Harlan Grove, worksheet.functions, 2003-10-20
 'concatenate all non digits   found in a string
 Dim i As Long, n As Long
 n = Len(s)
 For i = 1 To n
  If Mid(s, i, 1) Like "[0-8]" Then Mid(s, i, 1) = "9"
 Next i
 RemoveDigitsAll = Application.WorksheetFunction.Substitute(s, "9", "")
End Function

Function DigitsFirstID(s As String) As String
  'Harlan Grove, worksheet.functions, 2003-10-20
  'extract first string of  digits,  based on
  '-- http://google.com/groups?threadm=_RKkb.24635%24cJ5.3777@www.newsranger.com
    Dim i As Long, j As Long, n As Long
    n = Len(s)
    i = 1
    Do While i <= n And Mid(s, i, 1) Like "[!0-9]"
        i = i + 1
    Loop
    j = i + 1
    Do While j <= n And Mid(s, j, 1) Like "[0-9]"
        j = j + 1
    Loop
    DigitsFirstID = Mid(s, i, j - i)
End Function

Function DigitsDashes1stID(s As String) As String
  'get the longest continuous string of digits and dashes, based on
  'Harlan Grove, worksheet.functions, 2003-10-20
  'extract first string of  digits and dashes
  '-- http://google.com/groups?threadm=_RKkb.24635%24cJ5.3777@www.newsranger.com
    Dim i As Long, j As Long, n As Long
    n = Len(s)
    i = 1
    Do While i <= n And Mid(s, i, 1) Like "[!-0-9]"
        i = i + 1
    Loop
    j = i + 1
    Do While j <= n And Mid(s, j, 1) Like "[-0-9]"
        j = j + 1
    Loop
    DigitsDashes1stID = Mid(s, i, j - i)
End Function

Function LongestDigitsDashesID(s As String) As String
'Harlan Grove, worksheet.functions, 2003-10-20
'extract longest string of contiguous digits and dashes
'-- http://google.com/groups?threadm=G%Xkb.24725%24cJ5.3903@www.newsranger.com
Dim i As Long, j As Long, k As Long, n As Long

j = 0  'unnecessary but pedantic
k = 0  'unnecessary but pedantic
n = Len(s)

Do While i <= n

i = j + 1
Do While i <= n And Mid(s, i, 1) Like "[!-0-9]"
i = i + 1
Loop

j = i + 1
Do While j <= n And Mid(s, j, 1) Like "[-0-9]"
j = j + 1
Loop

If j - i > k Then
k = j - i
LongestDigitsDashesID = Mid(s, i, k)
End If

Loop
End Function

Function DigitisDashesNthID(ByVal s As String, Optional n As Long = 1) As Variant
Dim i As Long, j As Long, k As Long, m As Long, rv As Variant

If Not s Like "*[-0-9]*" Then
DigitisDashesNthID = IIf(n = 0, Array(""), "")
Exit Function
End If

s = s & " "

m = Len(s)
j = 0
k = 0
ReDim rv(1 To Int(m / 2))

For i = 1 To m

If Mid(s, i, 1) Like "[!-0-9]" And j > 0 Then
k = k + 1
rv(k) = Mid(s, j, i - j)
j = 0

ElseIf Mid(s, i, 1) Like "[-0-9]" And j = 0 Then
j = i

End If

Next i

ReDim Preserve rv(1 To k)

If n = 0 Then
DigitisDashesNthID = rv  'return an array of all [-0-9] substrings

ElseIf 1 <= n And n <= k Then
DigitisDashesNthID = rv(n)  'n_th [-0-9] substring from the left

ElseIf -k <= n And n <= -1 Then
DigitisDashesNthID = rv(k + 1 + n)  'ABS(n)_th [-0-9] substring from the right

Else
DigitisDashesNthID = IIf(n > 0, ">", "<")  'no n_th or ABS(n)_th [-0-9] substring

End If

End Function


Sub LeaveDigits_andDashes()
  Dim cell As Range   '2003-10-18 dmcritchie, misc, modified
  If Intersect(Selection, Selection.SpecialCells(xlConstants, _
         xlTextValues)) Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual   'pre XL97 xlManual
  For Each cell In Intersect(Selection, _
            Selection.SpecialCells(xlConstants, xlTextValues))
    cell.Value = "'" & LongestDigitsDashesID
  Next cell
  Application.Calculation = xlCalculationAutomatic  'pre XL97 xlAutomatic
  Application.ScreenUpdating = True
End Sub
Sub LeaveNonDigits()
  Dim cell As Range   '2003-10-18 dmcritchie, misc, modified
  Dim rng As Range
  On Error Resume Next
  Set rng = Intersect(Selection, Selection.SpecialCells(xlConstants))
  On Error GoTo 0
  If rng Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual   'pre XL97 xlManual
  For Each cell In rng
    cell.Value = "'" & RemoveDigitsAll(cell.Value)
  Next cell
  Application.Calculation = xlCalculationAutomatic  'pre XL97 xlAutomatic
  Application.ScreenUpdating = True
End Sub


'---/////  Harlan Grove -- possibly these should be split out  --end--///

'the following are based on the above...

Function AlphaWithDigits(ByVal s As String) As String
 'D.McRitchie, .excel,  2004-02-15 modified string for LIKE
 'otherwise is same as a posting
 'by Harlan Grove, worksheet.functions, 2003-10-20
 Dim i As Long, n As Long
 n = Len(s)
 For i = 1 To n
  If Not Mid(s, i, 1) Like "[0-9A-Za-z]" Then Mid(s, i, 1) = " "
 Next i
 AlphaWithDigits = Application.WorksheetFunction.Substitute(s, " ", "")
End Function

Function AlphaWithDigitsSpaces(ByVal s As String) As String
 'D.McRitchie, .excel,  2004-02-15 modified string for LIKE
 'otherwise is same as a posting
 'by Harlan Grove, worksheet.functions, 2003-10-20
 Dim i As Long, n As Long
 n = Len(s)
 For i = 1 To n
  If Not Mid(s, i, 1) Like "[ 0-9A-Za-z]" Then Mid(s, i, 1) = "^"
 Next i
 AlphaWithDigitsSpaces = Application.Trim(Application.WorksheetFunction.Substitute(s, "^", ""))
End Function

Function RegExpr_strXX(inCell As String, _
            myLike As String, _
            myRep As String) As String
'Bernie Dietrick, programming, 2004-06-18
'   =RegExpr_str(A3," ($??.??)","")
            
Dim i As Long
Dim iP As Long
Dim myStr As String

iP = 0
If inCell Like "*" & myLike & "*" Then
    For i = 1 To Len(inCell) - _
        Len(Replace(inCell, Left(myLike, 1), ""))
        iP = InStr(iP + 1, inCell, Left(myLike, 1))
        myStr = Mid(inCell, iP, Len(myLike))
        If myStr Like myLike Then
            RegExpr_strXX = Left(inCell, iP - 1) & myRep & _
            Mid(inCell, iP + Len(myLike), Len(inCell))
            Exit Function
        End If
    Next i
End If
RegExpr_strXX = inCell
End Function

Function RegExpr_str(inCell As String, _
            myLike As String) As String
'David McRitchie, programming, 2004-06-18
'   =RegExpr_str(A3," ($??.??)","")
   RegExpr_str = inCell Like myLike
End Function
Function NUL(Optional s1 As String, Optional s2 As String, _
    Optional s3 As String, Optional s4 As String)
    NUL = ""
End Function
Function RegExpr_LIKE(cell As String, myLike As String) As Boolean
  If cell = "" Or myLike = "" Then
     RegExpr_LIKE = 0
     Exit Function
  Else
     RegExpr_LIKE = cell Like myLike
  End If
End Function

 

Sub RegExpTest_q()
    MsgBox RegExpTest("^[0-9]{3}$", "211")
End Sub

Function RegExpTest(patrn, strng) As String
' Jim Rech, 2003-04-13, Set a reference to Microsoft VBScript
' Regular Expressions (vbscript.dll) and you should be able to run...

' -- operands seem backward to me but that is the way Jim put them...
 If patrn = "" Or strng = "" Then Exit Function

   Dim regEx As RegExp, Match As Match
   Dim Matches As MatchCollection
   Dim RetStr As String
   Set regEx = New RegExp   ' Create a regular expression.
   regEx.pattern = patrn   ' Set pattern.
   regEx.IgnoreCase = True   ' Set case insensitivity.
   regEx.Global = True   ' Set global applicability.
   Set Matches = regEx.Execute(strng)   ' Execute search.
   For Each Match In Matches   ' Iterate Matches collection.
      RetStr = RetStr & "Match found at position "
      RetStr = RetStr & Match.FirstIndex & ". Match Value is '"
      RetStr = RetStr & Match.Value & "'." & vbCrLf
   Next
   RegExpTest = RetStr
End Function

'' -- Regex.Replace(source1, pattern2, replacement3)
''-- unsuccessful of getting something to work...
'Function RegExpr_Replace(source1 As String, pattern2 As String, _
'        replacement3 As String) As String
'   Dim regEx As RegExp
'  Set regEx = New RegExp ' Create a regular expression.
'   regEx.pattern = pattern2 ' Set pattern.
'   RegExpr_Replace = regEx.Replace(source1, pattern2, replacement3)
'End Function