Sorting out with a search string

[Viswateja]

Dear All,

I have an excel file as attached below. I have to create a filter for yellow coloured cells of column A, with which I should be able to copy all the rows that comes under that respective yellow coloured cells. For example if I give filter as "31MBA" for the first column of the "Input Sheet", the output should be as shown in the "Output Sheet" in a numerical sequence (i.e. starting with 31MBA001/1, 31MBA001/2..then succeeding with 31MBA002/1, 31MBA002/2...so on and so forth. As the list is exhaustive to type manually, I have stopped with limited results in "Output Sheet"). Appreciate any help, as it's taking ages to complete this manually. Awaiting reply.

P.S: Please note that the original input sheet had more than 28000 rows. I had to chop down the rows due to the limitation on file size to upload.

[jindon]

Sub test()
    Dim myAreas As Areas, r As Range, myID, SL As Object, i As Long
    Dim FilterVal As String
    FilterVal = Application.InputBox("Enter filter value", , "31MBA", , , , , 2)
    If FilterVal = "" Then Exit Sub
    Application.ScreenUpdating = False
    Set SL = CreateObject("System.Collections.SortedList")
    Set myAreas = Sheets("input sheet").Columns("b").SpecialCells(2).Areas
    For Each r In myAreas
        myID = r(0, 0).Value
        If UCase$(myID) Like UCase$(FilterVal) & "*" Then
            myID = GetSortVal(r(0, 0) & r.Row)
            Set SL(myID) = r.Offset(-1).Resize(r.Rows.Count + 1).EntireRow
        End If
    Next
    With Sheets("output sheet")
        .Cells.Clear
        For i = 0 To SL.Count - 1
            SL.GetByIndex(i).Copy .Range("a" & Rows.Count).End(xlUp)(2)
        Next
        .Rows(1).Delete
    End With
    Application.ScreenUpdating = True
End Sub

Function GetSortVal(txt As String) As String
    Dim i As Long, m As Object
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\d+"
        If .test(txt) Then
            For i = .Execute(txt).Count - 1 To 0 Step -1
                Set m = .Execute(txt)(i)
                txt = Application.Replace(txt, m.firstindex + 1, m.Length, Format$(m.Value, "0000000000"))
            Next
        End If
    End With
    GetSortVal = txt
End Function

[Viswateja]

Dear Jindon,

You were, are and hopefully will be my savior all the time. Fantastic work. Couldn't believe my eyes after executing the code. God Bless