Auto numbering based on values

[GEO81]

Hello!

I have a vba code which copies data from multiple workbooks into one based on criteria.
The criteria value is being copied as well to the generated worksheet at column D.
Now, I may have 3 rows for value=Criteria1 in column D and other 5 rows for value=Criteria2 in column D.
I want to have a sequential numbering for each Value as per below example

Numbering	Column D
1	Criteria1
2	Criteria1
3	Criteria1
1	Criteria2
2	Criteria2
3	Criteria2
4	Criteria2
5	Criteria2

What I'm currently using is just sequence all rows irrespective the value in column D.

Below is my full vba code in case is useful.

Thanks!

Sub SearchFolders()

  Dim fso As Object
  Dim fld As Object
  Dim strSearch As String
  Dim strPath As String
  Dim strFile As String
  Dim wOut As Worksheet
  Dim wbk As Workbook
  Dim wks As Worksheet
  Dim lRow As Long
  Dim rFound As Range
  Dim strFirstAddress As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False


    strPath = "C:\Users\cmkon\Desktop\CAMS"
    strSearch = InputBox("Enter Criteria")

    Dim MyArray() As String, I As Variant

    MyArray = Split(strSearch, ";")

 
 
 For Each I In MyArray
   
      Set wOut = ThisWorkbook.Worksheets("Data")
       
         With wOut

            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
           
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set fld = fso.GetFolder(strPath)


            strFile = Dir(strPath & "\*.xls*")
            Do While strFile <> ""
               Set wbk = Workbooks.Open _
               (Filename:=strPath & "\" & strFile, _
                UpdateLinks:=0, _
                ReadOnly:=True, _
                AddToMRU:=False)


        For Each wks In wbk.Worksheets
          Set rFound = wks.UsedRange.Find(I)
 
               
        If Not rFound Is Nothing Then
            strFirstAddress = rFound.Address
        End If
        Do
            If rFound Is Nothing Then
                Exit Do
            Else
                lRow = lRow + 1
               .Cells(lRow, 1) = wbk.Name
                .Cells(lRow, 2) = wks.Name
                .Cells(lRow, 3) = rFound.Address
                .Cells(lRow, 4) = rFound.Value
               .Cells(lRow, 5) = rFound.Offset(, -1).Value
              .Cells(lRow, 6) = lRow - 1

              End If
            Set rFound = wks.Cells.FindNext(After:=rFound)
        Loop While strFirstAddress <> rFound.Address
     
         
    Next


    wbk.Close (False)
    strFile = Dir
Loop
.Columns("A:F").EntireColumn.AutoFit

End With

Next I


MsgBox "Done"

ExitHandler:
 Set wOut = Nothing
 Set wks = Nothing
 Set wbk = Nothing
 Set fld = Nothing
 Set fso = Nothing
 Application.ScreenUpdating = True
Exit Sub


ErrHandler:
 MsgBox Err.Description, vbExclamation
 Resume ExitHandler


End Sub

 

[kokano90]

Is your column D sorted?

 

[GEO81]

Is your column D sorted?

Yes.