VBA Parse out the 3 digit numbers

S

Stephen_IV

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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
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
 
Upvote 0
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]
 
Upvote 0
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
 
Upvote 0
A possible solution using formulas


[Table="class: grid"][tr][td="bgcolor: #DCE6F1"][/td][td="bgcolor: #DCE6F1"]
A​
[/td][td="bgcolor: #DCE6F1"]
B​
[/td][td="bgcolor: #DCE6F1"]
C​
[/td][td="bgcolor: #DCE6F1"]
D​
[/td][td="bgcolor: #DCE6F1"]
E​
[/td][td="bgcolor: #DCE6F1"]
F​
[/td][td="bgcolor: #DCE6F1"]
G​
[/td][/tr]
[tr][td="bgcolor: #DCE6F1"]
1​
[/td][td]
Intermediate Administrator (092)​
[/td][td]
092​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
2​
[/td][td]
Special Education 065, 165​
[/td][td]
065​
[/td][td]
165​
[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
3​
[/td][td]
Teaching certification (065, 165, or 265)​
[/td][td]
065​
[/td][td]
165​
[/td][td]
265​
[/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
4​
[/td][td]
Math, (029, 229)​
[/td][td]
029​
[/td][td]
229​
[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
5​
[/td][td]
English, Grades 7-12 (015)​
[/td][td]
015​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
6​
[/td][td]
General Science, Grades 7-12 (034, 234)​
[/td][td]
034​
[/td][td]
234​
[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
7​
[/td][td]
Elementary (013, 001, 002, 004, or 005)​
[/td][td]
013​
[/td][td]
001​
[/td][td]
002​
[/td][td]
004​
[/td][td]
005​
[/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
8​
[/td][td]
Music, Grades PK-12 (049)​
[/td][td]
049​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td="bgcolor: #DCE6F1"]
9​
[/td][td]
World Language 101, Bilingual (009 OR 902)​
[/td][td]
101​
[/td][td]
009​
[/td][td]
902​
[/td][td][/td][td][/td][td][/td][/tr]
[/table]

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.
 
Upvote 0
Leith Ross said:
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
Click to expand...
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.
 
Upvote 0
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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Find the data and get the cell address
Replies
4
Views
473
Peter_SSs
Peter_SSs
H
  • Solved
Creation of arrows for 2 family trees.
Replies
8
Views
372
harzer
H
H
  • Solved
Modify content of cells in column "F" according to the content of cells in column "A"
Replies
5
Views
520
igold
igold
H
  • Solved
Count nonblank lines (between blank lines)
2
Replies
15
Views
1K
Alex Blakenburg
A
E
  • Solved
Can someone tell me why the first column is not displaying all info?
Replies
3
Views
161
RoryA
RoryA

Forum statistics

Threads
1,224,818
Messages
6,181,152
Members
453,021
Latest member
Justyna P

Share this page

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
Back
Top