VBA Parse out the 3 digit numbers

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
966
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

MrExcel MVP
Joined
May 26, 2009
Messages
16,666
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
35,504
Office Version
2010
Platform
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,869
Office Version
2010, 2007
Platform
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,317
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
35,504
Office Version
2010
Platform
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
966
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!
 

Forum statistics

Threads
1,081,747
Messages
5,361,038
Members
400,610
Latest member
ebey

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top