Thanks for seeing my thread. Need one small help from you. Need to select an Order_Num range and cust_Num range from the given below sheet. Before Sheet looks below :-

1. First Order_Num - 141 it have two lines and cust_num for Order id is also have same Cust_num. So Order_range in D3 is "A2 to A3" and Cust_range in E3 is "C2 to C3"
2. 2nd Order_Num - 146 its have four lines and cust_num for Order id have two cust_num. So Order_range in D7 is "A4 to A7" and Cust_range have two cust_id so in E5 is "C4 to C6" and in E6 range is "C7 to C7".
3. 3rd Order id - 148 has 3 lines and two cust_num for the same. And Order_range in D10 is "A8 to A10" and Cust_range in E9 is "C8 to C9" and in E10 is "C10 to C10"

So the final Sheet should be like:-

I have written a code till the Order_range selection and got stuck in writing Cust_range selection and My code:-

Private Sub CommandButton1_Click()

Dim ws1 As Worksheet, rng As Long, lastrow As Long, FirstInvoice As String, Count As Long, A As Long, Count1 As Long
Dim intComp As Integer, B As Long
Set ws1 = Sheets("Sheet1")
lastrow = ws1.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

FirstInvoice = Cells(2, "A").Value
    If FirstInvoice <> "" Then
        Count = 1
        Count1 = 2
    End If

For A = 2 To lastrow   1
  intComp = StrComp(FirstInvoice, Cells(A, "A").Value)

  If intComp = 0 Then

    Count = Count   1

  Else

    ' MsgBox (" First Order_Num range from " & Count1 & "to range = " & Count)
     ws1.Cells(A - 1, "D").Value = "A" & Count1 & " to " & "A" & Count

    'Start- Enter here for Cust_range selection

    'End- for Cust_range selection
    
    Count = Count   1
    Count1 = A
    FirstInvoice = Cells(A, "A").Value

  End If

Next A

End Sub

CodePudding user response：

Please, try using the next piece of code. As I said in my above comment, it uses arrays, two dictionaries and place the processed result in arrays, too, working mostly in memory. The processed array content will be dropped at once. So, the code should be very fast for a big range to be processed:

Sub ExtractRanges()
   Dim sh As Worksheet, lastR As Long, dictA As Object, dictC As Object
   Dim i As Long, arr, arrItem, arrD, arrE
   
   Set sh = ActiveSheet 'Sheets("Sheet1")
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row on A:A
   arr = sh.Range("A1:C" & lastR).Value2 'place the range in an array for faster iteration/processing
   
   Set dictA = CreateObject("Scripting.Dictionary") 'set the necessary dictionaries
   Set dictC = CreateObject("Scripting.Dictionary")
   For i = 2 To UBound(arr)                                           'iterate between the array rows
        If Not dictA.Exists(arr(i, 1)) Then                        'if the key does not exist:
            dictA.Add arr(i, 1), i                                          'create it and use the array row as item
        Else
            arrItem = Split(dictA(arr(i, 1)), "|")                 'split the item by "|"
            If UBound(arrItem) = 0 Then                           'if no "|" exists (yet):
               dictA(arr(i, 1)) = dictA(arr(i, 1)) & "|" & i    'add the last (found) row after "|"
            Else
                arrItem(1) = i: dictA(arr(i, 1)) = Join(arrItem, "|") 'change the second parameter as the last row
            End If
        End If
        
        If Not dictC.Exists(arr(i, 1) & arr(i, 3)) Then
            dictC.Add arr(i, 1) & arr(i, 3), i
        Else
            arrItem = Split(dictC(arr(i, 1) & arr(i, 3)), "|")
            If UBound(arrItem) = 0 Then
               dictC(arr(i, 1) & arr(i, 3)) = dictC(arr(i, 1) & arr(i, 3)) & "|" & i
            Else
                arrItem(1) = i: dictC(arr(i, 1) & arr(i, 3)) = Join(arrItem, "|")
            End If
        End If
   Next i
   
   Dim key, iRow As Long
   'process Order_Range: ______________________________________
   ReDim arrD(1 To UBound(arr), 1 To 1)
   For Each key In dictA.Keys          'iterate between the dictionary keys
        arrItem = Split(dictA(key), "|") 'split the item by "|"
        If UBound(arrItem) = 0 Then    'if no "|":
            iRow = dictA(key) - 1
            arrD(iRow, 1) = "A" & iRow & " to A" & iRow 'build the necessary string to be placed in array
        Else
            iRow = CLng(arrItem(1)) - 1
            arrD(iRow, 1) = "A" & arrItem(0) & " to A" & iRow   1 'build the string from the item elements
        End If
   Next
   'Drop the array result at once:
   sh.Range("D2").Resize(UBound(arrD) - 1, 1).Value2 = arrD
   '_____________________________________________________________
   
   'process Cust_Range: ______________________________________
   ReDim arrrE(1 To UBound(arr), 1 To 1)
   For Each key In dictC.Keys
        arrItem = Split(dictC(key), "|")
        If UBound(arrItem) = 0 Then
            iRow = dictC(key) - 1
            arrrE(iRow, 1) = "C" & iRow   1 & " to C" & iRow   1
        Else
            iRow = CLng(arrItem(1)) - 1
            arrrE(iRow, 1) = "C" & arrItem(0) & " to C" & iRow   1
        End If
   Next
   'Drop the array result at once:
   sh.Range("E2").Resize(UBound(arrrE) - 1, 1).Value2 = arrrE
   '_____________________________________________________________
   
   MsgBox "Ready..."
End Sub

Please, send some feedback after testing it.

If something not clear enough, do not hesitate to ask for clarifications...