Extract all numbers in an expression

C

ChewCS

New Member
Joined
Jun 17, 2022
Messages
15
Office Version
  1. 2016
Platform
  1. Windows
Hi, I would like to seek assistance from this forum in a certain task.

I have a cell with an expression that includes ranges of numbers. Something like "1-3,13,15-17". I would like to have a VBA function that extracts all the numbers within this single expression and store them in an array. Something like

array(1,1) is 1, array(1,2) is 2, array(1,3) is 3, array(1,4) is 13, array(1,5) is 15, array(1,6) is 16, array(1,7) is 17.

Is it possible?

Thanks in advance!
 
Sort by date Sort by votes
Would this work?

VBA Code: 
Dim inArray() As Variant
Dim outArray(300, 50) As Variant
Dim ary As Variant
Dim M, N, P
Dim S As String
Dim T As Long, Ta As Long, X As Long


ref = "A1:B10"     'defined size
path = Application.ThisWorkbook.path & "\"
file = "test.xlsx"
sheet = "Sheet1"
arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref


' READ FILE

With Range(ref)
    .FormulaArray = "=" & arg
    .Value = .Value
End With

inArray = Range(ref)

' READ & CONVERT STRING
k = 1
Do While inArray(k, 1) > 0

    S = inArray(k, 1)
    P = Split(Replace(S, "-", ","), ",")
    ReDim ary(1 To 1, 1 To Val(P(UBound(P))))
    M = Split(S, ",")
    For T = 0 To UBound(M)
        If InStr(1, M(T), "-") > 0 Then
            N = Split(M(T), "-")
            For Ta = Val(N(0)) To Val(N(UBound(N)))
                X = X + 1
                ary(1, X) = Ta
            Next Ta
        Else
            X = X + 1
            ary(1, X) = Val(M(T))
        End If
    Next T
    ReDim Preserve ary(1 To 1, 1 To X)
    
    For i = 1 To X
        outArray(k, i) = ary(1, i)
    Next i

    k = k + 1

' REM End of while loop
Loop
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
I will let @kvsrinivasamurthy answer you on that one, since that is based around his code.

I modfied mine to tack on on to the bottom of your code and its not pretty but it seems to work.
Actually I have made some minor modifications to your code including increasing the range from A:B to A:E so you will need to copy the whole module.

VBA Code: 
Sub ReadInputFileRefmtWeeks()

    ' Original Code - added Dim statements & expanded range to column E
    Dim inArray() As Variant
    Dim ref As String, Path As String, file As String, arg As String
    Dim sht As String
    
    ref = "A1:E10"     'defined size
    Path = Application.ThisWorkbook.Path & "\"
    file = "test.xlsx"
    Sheet = "Sheet1"

    arg = "'" & Path & "[" & file & "]" & sht & "'!" & ref
    
    With Range(ref)
        .Formula = "=" & arg
        .Value = .Value
    End With
    
    inArray = Range(ref)
    
    '--------------------------------------------------------
    ' Added Code to Split Weeks & Reformat
    '--------------------------------------------------------
    ' Split weeks
    Dim noOfWeeks As Long
    Dim i As Long
    Dim arrWks() As Variant
    Dim lastCol As Long
    Dim arrWkRanges As Variant      ' Data Sample --> 1-6,11,13,15,17
    Dim arrFirstLast As Variant     ' Data Sample --> 1-6 split into (0) = 1, (1) = 6 / 11 split into (0) = 11
    Dim iWkRanges As Long, WkNo As Long, outRow As Long
    
    noOfWeeks = 18
    lastCol = Range(ref).Columns.Count
    ReDim arrWks(1 To UBound(inArray, 1), 1 To noOfWeeks)
    
    ' Set up headings for weeks
    For i = 1 To noOfWeeks
        arrWks(1, i) = "Weeks " & i
    Next i
    
    ' Split out Sequence of weeks
    For i = 2 To UBound(inArray, 1)
        If inArray(i, 5) <> 0 Then
            arrWkRanges = Split(inArray(i, 5), ",")
            For iWkRanges = 0 To UBound(arrWkRanges)
                arrFirstLast = Split(arrWkRanges(iWkRanges), "-")
                For WkNo = arrFirstLast(0) To arrFirstLast(UBound(arrFirstLast))
                    arrWks(i, WkNo) = 1
                Next WkNo
            Next iWkRanges
        Else
            outRow = i
            Exit For
        End If
    Next i
    
    ' Output results
    Cells(1, lastCol + 1).Resize(outRow - 1, noOfWeeks).Value = arrWks
    Columns(2).NumberFormat = "hh:mm"
    Columns(3).NumberFormat = "[h]:mm"
    Cells(1).CurrentRegion.Columns.AutoFit
    Rows(outRow & ":" & Range(ref).Rows.Count).Delete

End Sub
 
Upvote 0
Solution
Range used for input is E2:E3, can be changed as required. 2D array is generated (ary). Array Rows depends on input range, in this case 2 rows. Columns are 18 as per your requirement.
VBA Code: 
Sub Get2Darray()
Dim M, N, P, S
Dim T As Long, Ta As Long, X As Long, Ro As Long

S = Range("E2:E3")
ReDim ary(1 To UBound(S, 1), 1 To 18) As Integer

For Ro = 1 To UBound(S, 1)
P = Split(Replace(S(Ro, 1), "-", ","), ",")
M = Split(S(Ro, 1), ",")
    For T = 0 To UBound(M)
   
    If InStr(1, M(T), "-") > 0 Then
    N = Split(M(T), "-")
        For Ta = Val(N(0)) To Val(N(UBound(N)))
        ary(Ro, Ta) = 1
        Next Ta
    Else
    ary(Ro, Val(M(T))) = 1
    End If
   
    Next T
Next Ro
'enter array values in the range
Range("F2").Resize(UBound(S, 1), 18) = ary
End Sub
 
Upvote 0
This is my input file test.xlsx. It only has 3 rows of strings for testing
1-3,13,15-18
2,4,6,12,14,16
1,3,5,7,13,15,17

And below is my script. Somehow it says ary is out of bounds.

VBA Code: 
Private Sub CommandButton1_Click()

Dim path As String, file As String
Dim dest As String
Dim fname As String
Dim sheet As String, ref As Variant

Dim arg As String
Dim filename As String

Dim sh As Worksheet
Dim i, j, k
    
Dim NoRanges As Variant
Dim FirstLast As Variant
Dim outArr() As Long
Dim outRow As Long
Dim ary As Variant

Dim M, N, P, S
Dim T As Long, Ta As Long, X As Long, Ro As Long
    
Application.EnableEvents = False
Application.ScreenUpdating = False

ref = "A1:S22"
path = Application.ThisWorkbook.path & "\"
file = "test.xlsx"
sheet = "Sheet1"

filename = VBA.FileSystem.Dir(path & file)
If filename = VBA.Constants.vbNullString Then

    Cells(5, 1) = "file does not exist."

Else

    arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref

    With Range(ref)
                    
        .FormulaArray = "=" & arg
        .Value = .Value
        
    End With
    S = Range(ref)
    
End If

ReDim ary(1 To UBound(S, 1), 1 To 18) As Integer

For Ro = 1 To UBound(S, 1)
    P = Split(Replace(S(Ro, 1), "-", ","), ",")
    M = Split(S(Ro, 1), ",")
    For T = 0 To UBound(M)
  
        If InStr(1, M(T), "-") > 0 Then
            N = Split(M(T), "-")
            For Ta = Val(N(0)) To Val(N(UBound(N)))
            ary(Ro, Ta) = 1
            Next Ta
        Else
            ary(Ro, Val(M(T))) = 1
        End If
  
    Next T
Next Ro

Range("A1").Resize(UBound(S, 1), 18) = ary


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Honestly, I'm not sure if I am doing reading the file properly and assigning its values to "ref".
 
Upvote 0
I have done changes in code. Try.
VBA Code: 
Private Sub CommandButton1_Click()

Dim path As String, file As String
Dim dest As String
Dim fname As String
Dim sheet As String
Dim ref As Range  ' Inserted

Dim arg As String
Dim filename As String

Dim sh As Worksheet
Dim i, j, k
    
Dim NoRanges As Variant
Dim FirstLast As Variant
Dim outArr() As Long
Dim outRow As Long
Dim ary As Variant

Dim M, N, P, S
Dim T As Long, Ta As Long, Ro As Long
    
Application.EnableEvents = False
Application.ScreenUpdating = False

Set ref = Range("A1:S22")          'ref = "A1:S22"   Changed
path = Application.ThisWorkbook.path & "\"
file = "test.xlsx"
sheet = "Sheet1"

filename = VBA.FileSystem.Dir(path & file)
If filename = VBA.Constants.vbNullString Then

    Cells(5, 1) = "file does not exist."

Else

    arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref

    With ref                         'Range(ref)  Changed
                    
        .FormulaArray = "=" & arg
        .Value = .Value
        
    End With
'Getting array
'S should refer to single column having your input only. In this case A1:A22
S = ref.Columns(1)         'Range(ref) Changed

End If

ReDim ary(1 To UBound(S, 1), 1 To 18) As Integer

For Ro = 1 To UBound(S, 1)
    P = Split(Replace(S(Ro, 1), "-", ","), ",")
    M = Split(S(Ro, 1), ",")
    For T = 0 To UBound(M)
  
        If InStr(1, M(T), "-") > 0 Then
            N = Split(M(T), "-")
            For Ta = Val(N(0)) To Val(N(UBound(N)))
            ary(Ro, Ta) = 1
            Next Ta
        Else
            ary(Ro, Val(M(T))) = 1
        End If
  
    Next T
Next Ro

Range("B1").Resize(UBound(S, 1), 18) = ary  'B1 is the first cell of ArraYy result


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
 
Upvote 0
kvsrinivasamurthy said:
I have done changes in code. Try.
VBA Code: 
Private Sub CommandButton1_Click()

Dim path As String, file As String
Dim dest As String
Dim fname As String
Dim sheet As String
Dim ref As Range  ' Inserted

Dim arg As String
Dim filename As String

Dim sh As Worksheet
Dim i, j, k
   
Dim NoRanges As Variant
Dim FirstLast As Variant
Dim outArr() As Long
Dim outRow As Long
Dim ary As Variant

Dim M, N, P, S
Dim T As Long, Ta As Long, Ro As Long
   
Application.EnableEvents = False
Application.ScreenUpdating = False

Set ref = Range("A1:S22")          'ref = "A1:S22"   Changed
path = Application.ThisWorkbook.path & "\"
file = "test.xlsx"
sheet = "Sheet1"

filename = VBA.FileSystem.Dir(path & file)
If filename = VBA.Constants.vbNullString Then

    Cells(5, 1) = "file does not exist."

Else

    arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref

    With ref                         'Range(ref)  Changed
                   
        .FormulaArray = "=" & arg
        .Value = .Value
       
    End With
'Getting array
'S should refer to single column having your input only. In this case A1:A22
S = ref.Columns(1)         'Range(ref) Changed

End If

ReDim ary(1 To UBound(S, 1), 1 To 18) As Integer

For Ro = 1 To UBound(S, 1)
    P = Split(Replace(S(Ro, 1), "-", ","), ",")
    M = Split(S(Ro, 1), ",")
    For T = 0 To UBound(M)
 
        If InStr(1, M(T), "-") > 0 Then
            N = Split(M(T), "-")
            For Ta = Val(N(0)) To Val(N(UBound(N)))
            ary(Ro, Ta) = 1
            Next Ta
        Else
            ary(Ro, Val(M(T))) = 1
        End If
 
    Next T
Next Ro

Range("B1").Resize(UBound(S, 1), 18) = ary  'B1 is the first cell of ArraYy result


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
Click to expand...

arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref

I think this line doesn't work with the new ref definition.
 
Upvote 0
Change this line

arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref

as

arg = "'" & path & "[" & file & "]" & sheet & "'!" & ref.address
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
User Defined Formula to Generate Polynomial Regression Equation
Replies
1
Views
732
Dave Patton
D
B
  • Solved
Extracting a specific number of characters from a multiline cell
Replies
7
Views
319
etaf
etaf
Z
  • Question Question
VBA: Pass Args back to Sub from PVT Sub
Replies
4
Views
161
Skyybot
Skyybot
S
  • Question Question
Extract allways changing (and unknown) number at end of string
Replies
6
Views
497
strooman
S
V
  • Solved
Extracting numbers from a string and adding them up
2
Replies
19
Views
1K
Vector8086
V

Forum statistics

Threads
1,223,264
Messages
6,171,081
Members
452,377
Latest member
bradfordsam

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