求助大神 如果得出同条件下哪个价格最低跟最高

一只猫！

如图  怎么样用VBA写出同一发货地址，相同重量的情况下，哪个快递的价格最便宜，以及哪个快递的价格最贵呢

不知道为什么

几年前写过的一个二维数组的排序函数，感觉可以用上。如图 供参考

不知道为什么

排序后结果如图

蓝桥玄霜

价格的例子：

一只猫！

蓝桥玄霜 发表于 2023-4-25 16:14
价格的例子：

感谢大神   可以了

一只猫！

不知道为什么 发表于 2023-4-25 16:07
排序后结果如图

谢谢大神  谢谢大神

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         c = .Cells(3, .Columns.Count).End(xlToLeft).Column
   
9.         arr = .Range("a3").Resize(r - 2, c)
   
10.     End With
    
11.     s = 0
    
12.     For i = 3 To UBound(arr)
    
13.         If Not d.exists(arr(i, 1)) Then
    
14.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         For j = 2 To UBound(arr, 2)
    
17.             If Not d(arr(i, 1)).exists(arr(1, j)) Then
    
18.                 s = s + 1
    
19.                 ReDim brr(1 To 6)
    
20.                 brr(1) = arr(i, 1)
    
21.                 brr(2) = arr(1, j)
    
22.             Else
    
23.                 brr = d(arr(i, 1))(arr(1, j))
    
24.             End If
    
25.             If brr(3) = Empty Then
    
26.                 brr(3) = arr(2, j)
    
27.                 brr(4) = arr(i, j)
    
28.             Else
    
29.                 If brr(4) > arr(i, j) Then
    
30.                     brr(3) = arr(2, j)
    
31.                     brr(4) = arr(i, j)
    
32.                 End If
    
33.             End If
    
34.             If brr(5) = Empty Then
    
35.                 brr(5) = arr(2, j)
    
36.                 brr(6) = arr(i, j)
    
37.             Else
    
38.                 If brr(6) < arr(i, j) Then
    
39.                     brr(5) = arr(2, j)
    
40.                     brr(6) = arr(i, j)
    
41.                 End If
    
42.             End If
    
43.             d(arr(i, 1))(arr(1, j)) = brr
    
44.         Next
    
45.     Next
    
46.     m = 0
    
47.     ReDim crr(1 To s, 1 To 6)
    
48.     For Each aa In d.keys
    
49.         For Each bb In d(aa).keys
    
50.             m = m + 1
    
51.             brr = d(aa)(bb)
    
52.             For j = 1 To UBound(brr)
    
53.                 crr(m, j) = brr(j)
    
54.             Next
    
55.         Next
    
56.     Next
    
57.     With Worksheets("sheet2")
    
58.         .UsedRange.Offset(2, 0).Clear
    
59.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
    
60.         With .UsedRange
    
61.             .HorizontalAlignment = xlCenter
    
62.             .VerticalAlignment = xlCenter
    
63.         End With
    
64.     End With
    
65.         
    
66. End Sub
    

复制代码

perfect131

直接从sheet1获取最大最小也可以

https://club.excelhome.net/threa ... tml?_dsign=f81e01b8

liulang0808

perfect131

类 And 字典记录数组索引(无需字典嵌套）