sequence numbering

**jparmar** · 05-28-2016, 06:28 AM

Hello forum guys.
I am stuck up at one place regarding sequence numbering. I have attached a sheet for making it more clear.
The required output is shown in sheet2 , but it is actually required in the same sheet named Main when you run the code.
Wanted just an option . In case if the code is run and the output is required in the sheet name Option and not Main.

Thanks and have a nice day.

jparmar

**MickG** · 05-28-2016, 08:31 AM

Try this for Results in column "D" sheet "Main".

Sub MG28May03
Dim Rng As Range, Dn As Range, Ac As Integer, num As String, Str As String
Dim c As Long, n As Long, Ray(), col As Integer, Lc As Integer
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
c = 0
For Each Dn In Rng
    num = "": Str = ""
        For Ac = 1 To Len(Dn.Value)
            If Mid(Dn.Value, Ac, 1) Like "[0-9]" Then
                num = num + Mid(Dn.Value, Ac, 1)
            Else
                Str = Str & Mid(Dn.Value, Ac, 1)
            End If
        Next Ac
        col = IIf(Dn.Offset(, 1) = "", 0, Dn.Offset(, 1).Value)
        Lc = Lc + col + 1
        ReDim Preserve Ray(0 To Lc)
            For n = 0 To col
                Ray(c) = Str & num + n
                c = c + 1
            Next n
Next Dn
Range("D1").Resize(c) = Application.Transpose(Ray)
End Sub

Regards Mick

**sktneer** · 05-28-2016, 09:11 AM

Hi,

Welcome to the forum.

Please try this...

Sub SequenceNumber()
Dim ws As Worksheet
Dim sqNum(), data
Dim i As Long, j As Long, ii As Long
Dim Ans As String

Set ws = Sheets("Main")
data = ws.Range("A1").CurrentRegion.Value

ii = 1
For i = 1 To UBound(data, 1)
   For j = 0 To data(i, 2)
      ReDim Preserve sqNum(1 To ii)
      sqNum(ii) = Replace(CStr(data(i, 1)), ExtractNumber(CStr(data(i, 1))), "") & ExtractNumber(CStr(data(i, 1))) + j
      ii = ii + 1
   Next j
Next i
Ans = MsgBox("Do you want the output on the Option Sheet?", vbQuestion + vbYesNo)
If Ans = vbYes Then
   On Error Resume Next
   Set ws = Sheets("Option")
   If ws Is Nothing Then
      MsgBox "Option Sheet is not available in the workbook.", vbCritical, "Sheet Not Available!"
      Exit Sub
   End If
End If
ws.Columns("A").Clear
ws.Range("A1").Resize(UBound(sqNum)).Value = Application.Transpose(sqNum)
ws.Activate
End Sub

Function ExtractNumber(Str As String) As String
Dim RegEx As Object
Dim Match As Object

Set RegEx = CreateObject("vbscript.regexp")
RegEx.Pattern = "\d{1,}"
   
If RegEx.test(Str) = True Then
   Set Match = RegEx.Execute(Str)
   ExtractNumber = Match(0)
End If
End Function

In the attached, click the button on the Main Sheet to run the code.