根據Order_Num和Cust_Num中的重復值選擇范圍

感謝您看到我的執行緒。需要你的一點小幫助。需要從下表中選擇 Order_Num 范圍和 cust_Num 范圍。在作業表如下所示之前：-

1. 第一個 Order_Num - 141 它有兩行，并且 Order id 的 cust_num 也具有相同的 Cust_num。所以 D3 中的 Order_range 是“A2 到 A3”，E3 中的 Cust_range 是“C2 到 C3”
2. 2nd Order_Num - 146 它有四行，而 Order id 的 cust_num 有兩個 cust_num。所以 D7 中的 Order_range 是“A4 到 A7”，而 Cust_range 有兩個 cust_id，所以 E5 中是“C4 到 C6”，E6 中的范圍是“C7 到 C7”。
3. 3rd Order id - 148 有 3 行和兩個 cust_num 相同。D10 中的 Order_range 是“A8 到 A10”，E9 中的 Cust_range 是“C8 到 C9”，E10 中是“C10 到 C10”

所以最終的作業表應該是這樣的： -

我已經撰寫了一個代碼，直到 Order_range 選擇并陷入了撰寫 Cust_range 選擇和我的代碼：-

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

uj5u.com熱心網友回復：

請嘗試使用下一段代碼。正如我在上面的評論中所說，它使用陣列、兩個字典并將處理后的結果也放入陣列中，主要在記憶體中作業。處理后的陣列內容將立即被洗掉。因此，對于大范圍的處理，代碼應該非常快：

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

請在測驗后發送一些反饋。

如果有什么不夠清楚，請不要猶豫，要求澄清......

標籤：擅长vba

上一篇：如何從串列中洗掉單元格中的值

下一篇：在自定義選單中獲取下拉選單的選定項（并相應地運行宏）