```
Sub test()
'Declaring Variables
Dim a, i As Long, temp, x, result
'Assign values in current region to the variable 'a' in a given sheet
a = Range("a1").CurrentRegion.Value
'Creating a two-dimensional array with the number of items in a and 5 items.
Redim Preserve a(1 To UBound(a, 1), 1 To 5)
'Looping through each items in variable a
For i = 1 To UBound(a, 1)
'Calling Check Pattern function in order to assign the value for the temp
temp = CheckPattern(a(i, 1))
'split the string based on "|" in the string which is in temp.
x = Split(temp, "|")
'To see if the x is having one item or more than one item, and assigning values into the array.
If UBound(x) = 1 Then
a(i, 2) = x(0)
a(i, 3) = x(1)
a(i, 5) = a(i, 1)
Else
a(i, 2) = x(0)
a(i, 3) = x(1)
a(i, 4) = x(2)
a(i, 5) = x(0) & x(1)
End If
Next
'Call Function Get Grouped passing the array a
x = GetGrouped(a)
'Fetch the series from the given values
x = GetSeries(x(0), x(1), 100)
'Provide the result based on the function call, GetAligned passing in array and x.
result = GetAligned(a, x)
'It make sures that screen doesn't flicker
Application.ScreenUpdating = False
For i = 1 To UBound(result, 1)
If result(i, 1) = "" Then Rows(i).Insert
Next
Range("a1").Resize(UBound(result, 1), 2).Value = result
'Resetting above to make sure. Screen responds to user input
Application.ScreenUpdating = True
End Sub
'Checks for the pattern in the text passed to it
Private Function CheckPattern(ByVal txt As String) As String
Dim Fnum, Lnum
'Creates a Regular Expression
With CreateObject("VBScript.RegExp")
'Providing a pattern for which string needs to match.
.Pattern = "^(\D+)(\d+)$"
.IgnoreCase = True
If .test(txt) Then
'Returns this value
CheckPattern = .Replace(txt, "$1|$2")
Else
'If above pattern does not match then it comes to this loop and creates a new pattern
.Pattern = "^(\D+)(\d+) ?\-(.*\D)?(\d+)$"
If .test(txt) Then
'Replaces values in the string passed
Fnum = .Replace(txt, "$2")
Lnum = .Replace(txt, "$4")
If Len(Fnum) <> Len(Lnum) Then
'Assigns the Length of the String based on .. replace
Lnum = Application.Replace(Fnum _
, Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum)
End If
CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum
Else
'If above pattern does not match then it comes to this loop and creates a new pattern
.Pattern = "^(\D+)(\d+) DEN (\d+) .*$"
If .test(txt) Then
Fnum = .Replace(txt, "$2")
Lnum = .Replace(txt, "$3")
If Len(Fnum) <> Len(Lnum) Then
Lnum = Application.Replace(Fnum _
, Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum)
End If
CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum
End If
End If
End If
End With
End Function
'Groups items which are in the given array, based on unique items available/
Private Function GetGrouped(a As Variant) As Variant
Dim i As Long, w(), myNum
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
Redim w(1 To 4, 1 To 1)
w(1, 1) = a(i, 3)
w(2, 1) = IIf(a(i, 4) = "", a(i, 3), a(i, 4))
w(3, 1) = a(i, 3)
.Item(a(i, 2)) = w
Else
w = .Item(a(i, 2))
Redim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
w(1, UBound(w, 2)) = a(i, 3)
w(2, UBound(w, 2)) = IIf(a(i, 4) = "", a(i, 3), a(i, 4))
w(3, UBound(w, 2)) = _
w(2, UBound(w, 2)) - Val(w(1, UBound(w, 2) - 1))
.Item(a(i, 2)) = w
End If
Next
GetGrouped = VBA.Array(.keys, .items)
End With
End Function
'fetches the series from the given elements.
Function GetSeries(x, y, myLimit)
Dim i As Long, ii As Long, iii As Long
With CreateObject("System.Collections.ArrayList")
For i = LBound(x) To UBound(x)
If UBound(y(i), 2) = 1 Then
For iii = y(i)(1, 1) To y(i)(2, 1)
.Add x(i) & iii
Next
Else
.Add x(i) & y(i)(1, 1)
For ii = 2 To UBound(y(i), 2)
If y(i)(2, ii) > y(i)(2, ii - 1) And y(i)(3, ii) < myLimit Then
For iii = y(i)(2, ii - 1) + 1 To y(i)(2, ii)
.Add x(i) & iii
Next
Else
.Add x(i) & y(i)(1, ii)
End If
Next
End If
Next
GetSeries = .ToArray
End With
End Function
'Aligns the values in the given array.
Function GetAligned(p, x)
Dim i As Long, temp
Redim a(1 To UBound(x) + 1, 1 To 2)
With CreateObject("Scripting.Dictionary")
For i = 0 To UBound(x)
.Item(x(i)) = i + 1
a(i + 1, 2) = x(i)
Next
For i = 1 To UBound(p, 1)
temp = p(i, 2) & p(i, 3)
If .exists(temp) Then a(.Item(temp), 1) = p(i, 1)
Next
GetAligned = a
End With
End Function
```

Display More