VBA Parse out the 3 digit numbers

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
988
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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!
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,417
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
This assumes your header is in A1 and data down col A.
Code:
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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,969
Office Version
  1. 2016
Platform
  1. Windows
If you have a large amount of data, the following macro will be faster...
Code:
[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

Well-known Member
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
Hello Stephen_IV,

Here is alternate method...

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

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,510
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,969
Office Version
  1. 2016
Platform
  1. Windows
Hello Stephen_IV,

Here is alternate method...

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

Well-known Member
Joined
Mar 17, 2003
Messages
988
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,367
Messages
5,635,853
Members
416,886
Latest member
coreyalaurence37

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top