VBA Parse out the 3 digit numbers

[Stephen_IV]

Good evening I have a pretty large data set. with certifications. I need to parse the numbers out (the 3 digit ones)
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>Certification</th></tr></thead><tbody>
<tr><td>Intermediate Administrator (092)</td></tr>
<tr><td>Special Education 065, 165</td></tr>
<tr><td>Teaching certification (065, 165, or 265) </td></tr>
<tr><td>Math, (029, 229)</td></tr>
<tr><td>English, Grades 7-12 (015)</td></tr>
<tr><td>General Science, Grades 7-12 (034, 234)</td></tr>
<tr><td>Elementary (013, 001, 002, 004, or 005)</td></tr>
<tr><td>Music, Grades PK-12 (049)</td></tr>
<tr><td>World Language 101, Bilingual (009 OR 902)</td></tr>
</tbody></table>

I need to parse out all of the 3 digit numbers like so

<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>Certification</th><th> </th><th> </th><th> </th><th> </th><th> </th></tr></thead><tbody>
<tr><td>Intermediate Administrator (092)</td><td>092</td><td> </td><td> </td><td> </td><td> </td></tr>
<tr><td>Special Education 065, 165</td><td>065</td><td>165</td><td> </td><td> </td><td> </td></tr>
<tr><td>Teaching certification (065, 165, or 265) </td><td>065</td><td>165</td><td>265</td><td> </td><td> </td></tr>
<tr><td>Math, (029, 229)</td><td>029</td><td>229</td><td> </td><td> </td><td> </td></tr>
<tr><td>English, Grades 7-12 (015)</td><td>015</td><td> </td><td> </td><td> </td><td> </td></tr>
<tr><td>General Science, Grades 7-12 (034, 234)</td><td>034</td><td>234</td><td> </td><td> </td><td> </td></tr>
<tr><td>Elementary (013, 001, 002, 004, or 005)</td><td>013</td><td>001</td><td>002</td><td>003</td><td>005</td></tr>
<tr><td>Music, Grades PK-12 (049)</td><td>049</td><td> </td><td> </td><td> </td><td> </td></tr>
<tr><td>World Language 101, Bilingual (009 OR 902)</td><td>101</td><td>009</td><td>902</td><td> </td><td></td></tr>
</tbody></table>

Thanks in advance!

 

[JoeMo]

This assumes your header is in A1 and data down col A.

Sub Parse3DigitNumbers()
Dim R As Range, V As Variant, i As Long, Replc As Variant, c As Range, Spl As Variant, M As Long
Set R = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
V = R.Value
Replc = Array("(", ")", "or", "OR"", ", ",")
Application.ScreenUpdating = False
With R
    For i = LBound(Replc) To UBound(Replc)
        R.Replace Replc(i), " "
    Next i
    For Each c In .Cells
        Spl = Split(c.Value, " ")
        For i = 0 To UBound(Spl)
            If Spl(i) Like "###" Then
                ct = ct + 1
                If ct > M Then M = ct
                c.Offset(0, ct).Value = CStr(Spl(i))
            End If
        Next i
        ct = 0
    Next c
End With
R.Offset(0, 1).Resize(R.Rows.Count, M).NumberFormat = "000"
R.Value = V
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

If you have a large amount of data, the following macro will be faster...

[table="width: 500"]
[tr]
	[td]Sub GetThreeDigitNumbers()
  Dim R As Long, X As Long, Data As Variant, Result As Variant, Nums() As String
  Data = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  ReDim Result(1 To UBound(Data), 1 To 1)
  For R = 1 To UBound(Data)
    For X = 1 To Len(Data(R, 1))
      If Mid(Data(R, 1), X, 1) Like "[!0-9 ]" Then Mid(Data(R, 1), X) = " "
    Next
  Next
  For R = 1 To UBound(Data)
    Nums = Split(Data(R, 1))
    For X = 0 To UBound(Nums)
      If Len(Nums(X)) <> 3 Then Nums(X) = "" Else Nums(X) = Nums(X)
    Next
    Result(R, 1) = Application.Trim(Join(Nums))
  Next
  Range("B2").Resize(UBound(Result)) = Result
  Columns("B").TextToColumns , xlDelimited, , , False, False, False, True, False
  Range("A2").CurrentRegion.Offset(, 1).SpecialCells(xlConstants).NumberFormat = "000"
End Sub[/td]
[/tr]
[/table]

 

[Leith Ross]

Hello Stephen_IV,

Here is alternate method...

Sub ParseDigits()


    Dim Matches As Object
    Dim m       As Long
    Dim r       As Long
    Dim RegExp  As Object
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = ("\D(\d{3})\D")
            
        Set Rng = Wks.Range("A1").CurrentRegion
        
        Intersect(Rng, Rng.Offset(1, 1)).ClearContents
        
        For r = 2 To Rng.Rows.Count
            Set Matches = RegExp.Execute(Rng.Cells(r, "A"))
            For m = 0 To Matches.Count - 1
                Rng.Cells(r, "B").Offset(0, m).NumberFormat = "000"
                Rng.Cells(r, "B").Offset(0, m) = Matches(m).SubMatches(0)
            Next m
        Next r
        
End Sub

 

[Marcelo Branco]

A possible solution using formulas

	A​	B​	C​	D​	E​	F​	G​
1​	Intermediate Administrator (092)​	092​
2​	Special Education 065, 165​	065​	165​
3​	Teaching certification (065, 165, or 265)​	065​	165​	265​
4​	Math, (029, 229)​	029​	229​
5​	English, Grades 7-12 (015)​	015​
6​	General Science, Grades 7-12 (034, 234)​	034​	234​
7​	Elementary (013, 001, 002, 004, or 005)​	013​	001​	002​	004​	005​
8​	Music, Grades PK-12 (049)​	049​
9​	World Language 101, Bilingual (009 OR 902)​	101​	009​	902​

Array formula in B1 copied across and down
=IFERROR(MID($A1,SMALL(IFERROR(SEARCH(RIGHT("000"&ROW($1:$999),3),$A1),""),COLUMNS($B1:B1)),3),"")

confirmed with Ctrl+Shift+Enter, not just Enter

M.

 

[Rick Rothstein]

Hello Stephen_IV,

Here is alternate method...

Sub ParseDigits()


    Dim Matches As Object
    Dim m       As Long
    Dim r       As Long
    Dim RegExp  As Object
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = ("\D(\d{3})\D")
            
        Set Rng = Wks.Range("A1").CurrentRegion
        
        Intersect(Rng, Rng.Offset(1, 1)).ClearContents
        
        For r = 2 To Rng.Rows.Count
            Set Matches = RegExp.Execute(Rng.Cells(r, "A"))
            For m = 0 To Matches.Count - 1
                Rng.Cells(r, "B").Offset(0, m).NumberFormat = "000"
                Rng.Cells(r, "B").Offset(0, m) = Matches(m).SubMatches(0)
            Next m
        Next r
        
End Sub

Your code took an exceedingly long time to run against 1000 cells of data... 27.1 seconds on my computer. By comparison, JoeMo's code took 0.47 seconds and my code took 0.07 seconds. You can improve your code's speed dramatically by putting turning screen updating off the way JoeMo did (my code does not really benefit by doing it so I omitted it)... your code reduces to 0.62 seconds with screen updating turned off.

 

[Stephen_IV]

Thank you all for your help! I am amazed on how many brilliant people are on this forum! Thank you all again for your help!