大神帮忙看下代码错误

sunny568914

1. Sub 提取姓名种类唯一值到订单金额2()
   
2.     Dim arr, d As Object, i As Long, brr(), keys()
   
3.    
   
4.     Sheets("产量表").Activate
   
5.     arr = Sheets("产量表").Range("c2:D" & Cells(Rows.Count, 1).End(xlUp).Row)   '将数据放进数组arr
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) '定义数组brr大小
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.    
   
9.     For i = 1 To UBound(arr)
   
10.         s = arr(i, 1) & arr(i, 2) '如果是3列的要求就继续使用 & 链接....
    
11.         If Not d.Exists(s) Then '如果字典不存在s这个key
    
12.             k = k + 1 '计数
    
13.             d(s) = k '不存在s这个key就让它存在
    
14.             For j = 1 To UBound(arr, 2) '将数组arr的值通过遍历放到数组brr
    
15.                 brr(k, j) = arr(i, j)
    
16.             Next
    
17.         End If
    
18.     Next
    
19.    
    
20.     ' 将字典的key存入keys数组
    
21.     ReDim keys(1 To d.Count)
    
22.     i = 1
    
23.     For Each Key In d.keys
    
24.         keys(i) = Key
    
25.         i = i + 1
    
26.     Next
    
27.    
    
28.     ' 对keys数组进行排序
    
29.     Call QuickSort(keys, LBound(keys), UBound(keys))
    
30.    
    
31.     ' 按照排序后的key输出数据到"订单金额"表
    
32.     Sheets("订单金额").Range("A3").Resize(d.Count, UBound(brr, 2)) = Empty ' 清空"订单金额"表的内容
    
33.     For i = 1 To d.Count
    
34.         For j = 1 To UBound(brr, 2)
    
35.             Sheets("订单金额").Cells(i + 2, j).Value = brr(d(keys(i)), j)
    
36.         Next j
    
37.     Next i
    
38.    
    
39.     Sheets("订单金额").Activate
    
40. End Sub
    
41. 
    
42. ' 快速排序算法
    
43. Sub QuickSort(keys As Variant, L As Long, R As Long)
    
44.     Dim i As Long, j As Long
    
45.     Dim pivot As Variant, temp As Variant
    
46.     Dim production As Variant
    
47.    
    
48.     ' 保存产量表中A2:A30的内容到production数组
    
49.     production = Sheets("总金额").Range("A2:A30").Value
    
50.    
    
51.     i = L
    
52.     j = R
    
53.     pivot = production((L + R) \ 2, 1)
    
54.    
    
55.     Do While i <= j
    
56.         Do While Sheets("订单金额").Cells(i, 1).Value < pivot
    
57.             i = i + 1
    
58.         Loop
    
59.         Do While Sheets("订单金额").Cells(j, 1).Value > pivot
    
60.             j = j - 1
    
61.         Loop
    
62.         
    
63.         If i <= j Then
    
64.             temp = Sheets("订单金额").Cells(i, 1).Value
    
65.             Sheets("订单金额").Cells(i, 1).Value = Sheets("订单金额").Cells(j, 1).Value
    
66.             Sheets("订单金额").Cells(j, 1).Value = temp
    
67.             i = i + 1
    
68.             j = j - 1
    
69.         End If
    
70.     Loop
    
71.    
    
72.     If L < j Then QuickSort keys, L, j
    
73.     If i < R Then QuickSort keys, i, R
    
74. End Sub

复制代码

排序代码是AI生成的，但是运行会显示错误，If L < j Then QuickSort keys, L, j 溢出堆债空间

风雨声点滴

Sub QuickSort(keys As Variant, L As Long, R As Long)
    Dim i As Long, j As Long
    Dim pivot As Variant, temp As Variant

    i = L
    j = R
    pivot = keys((L + R) \ 2)

    Do While i <= j
        Do While keys(i) < pivot
            i = i + 1
        Loop
        Do While keys(j) > pivot
            j = j - 1
        Loop
        
        If i <= j Then
            temp = keys(i)
            keys(i) = keys(j)
            keys(j) = temp
            i = i + 1
            j = j - 1
        End If
    Loop

    If L < j Then QuickSort keys, L, j
    If i < R Then QuickSort keys, i, R
End Sub  
第二段换成这样，前面你的那个就是死循环来的

风雨声点滴

运行之后就能找你的要求排序并筛选了

sunny568914

风雨声点滴 发表于 2024-3-12 18:32
Sub QuickSort(keys As Variant, L As Long, R As Long)
    Dim i As Long, j As Long
    Dim pivot As ...

排序是根据总金额表中的A2：A30中的数据排序，这个代码的排序不是按总金额表的数据排序

风雨声点滴

Sub 提取姓名种类唯一值到订单金额2()
    Dim arr, d As Object, i As Long, brr(), s As String, x As Range
    Sheets("产量表").Activate
    'Application.AddCustomList Worksheets("产量表").Range("A2:a" & Rows.Count.End(xlUp).Row) -此句有误
    Application.AddCustomList Worksheets("总金额").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    h = Application.CustomListCount
    arr = Sheets("产量表").Range("c2:D" & Cells(Rows.Count, 1).End(xlUp).Row)   '将数据放进数组arr
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) '定义数组brr大小
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        s = arr(i, 1) & arr(i, 2) '如果是3列的要求就继续使用 & 链接....
        If Not d.Exists(s) Then '如果字典不存在s这个key就创建
            d.Add Key:=s, Item:=Empty
            For j = 1 To UBound(arr, 2) '将数组arr的值通过遍历放到数组brr
                brr(d.Count, j) = arr(i, j)
            Next j
        End If
    Next i
    Sheets("订单金额").UsedRange.Offset(1) = Empty ' 清空"订单金额"表除第一行的内容
    Sheets("订单金额").Cells(2, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Set x = Sheets("订单金额").Cells(2, 1).Resize(UBound(brr, 1), UBound(brr, 2))
    ' 按照排序后的key输出数据到"订单金额"表
    x.Sort key1:=Range("b2"), order1:=xlAscending, Header:=xlNo, ordercustom:=h + 1
    Sheets("订单金额").Activate
End Sub

可以了

sunny568914

风雨声点滴 发表于 2024-3-12 21:50
Sub 提取姓名种类唯一值到订单金额2()
    Dim arr, d As Object, i As Long, brr(), s As String, x As R ...

感谢可以用，学习了。

sunny568914

风雨声点滴 发表于 2024-3-12 21:50
Sub 提取姓名种类唯一值到订单金额2()
    Dim arr, d As Object, i As Long, brr(), s As String, x As R ...

老师，咨询下为什么有的时候会按指定的排序，有的时候未按指定排序

sunny568914

Sub 提取姓名种类唯一值到订单金额2()
    Dim arr, d As Object, i As Long, brr(), s As String, x As Range
    Sheets("产量表").Activate
    'Application.AddCustomList Worksheets("产量表").Range("A2:a" & Rows.Count.End(xlUp).Row) -此句有误
    Application.AddCustomList Worksheets("总金额").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    h = Application.CustomListCount
    arr = Sheets("产量表").Range("c2:D" & Cells(Rows.Count, 1).End(xlUp).Row)   '将数据放进数组arr
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) '定义数组brr大小
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        s = arr(i, 1) & arr(i, 2) '如果是3列的要求就继续使用 & 链接....
        If Not d.Exists(s) Then '如果字典不存在s这个key就创建
            d.Add Key:=s, Item:=Empty
            For j = 1 To UBound(arr, 2) '将数组arr的值通过遍历放到数组brr
                brr(d.Count, j) = arr(i, j)
            Next j
        End If
    Next i
    Sheets("订单金额").UsedRange.Offset(1) = Empty ' 清空"订单金额"表除第一行的内容
    Sheets("订单金额").Cells(2, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Set x = Sheets("订单金额").Cells(2, 1).Resize(UBound(brr, 1), UBound(brr, 2))
    ' 按照排序后的key输出数据到"订单金额"表
    x.Sort key1:=Range("b2"), order1:=xlAscending, Header:=xlNo, ordercustom:=h + 1
    Application.DeleteCustomList h
    Sheets("订单金额").Activate
End Sub

sunny568914

Application.DeleteCustomList h  添加了一句 删除自定义排序正常了