关键字有多个不同项，怎么同时写入字典

bosao

本求助从http://club.excelhome.net/thread-1037119-1-1.html扩展而来。
如果订单中同时满足多个条件的相同数据有多条，这些多条数据怎么同时写入字典，而不是新数据替换旧数据，又怎么返回最大数量及所在行号？

zhangzhang

Sub lqxs()
Dim Arr, i&, Brr, Crr, d
    Set d = CreateObject("Scripting.Dictionary")
    Sheets("校对").Activate

Arr = Sheets("订单").[a1].CurrentRegion

For i = 2 To UBound(Arr)
    x = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3) & "|" & Arr(i, 4)
    If Not d.exists(x) Then
        d(x) = i
    ElseIf Arr(i, 5) > d(x) Then
        d(x) = i
    End If
Next
Brr = [a1].CurrentRegion

ReDim Crr(1 To UBound(Brr) - 1, 1 To 2)

For i = 2 To UBound(Brr)
    x = Brr(i, 1) & "|" & Brr(i, 2) & "|" & Brr(i, 3) & "|" & Brr(i, 4)
    Crr(i - 1, 1) = Arr(d(x), 5)
    Crr(i - 1, 2) = d(x)
Next

Range("E2").Resize(UBound(Crr), 2) = Crr

Set d = Nothing
End Sub

zhangzhang

详见附件〉〉〉〉〉〉〉〉〉〉

zax010

改一点蓝版的代码：

Sub lqxs()
    Dim Arr, i&, Brr, d
    Set d = CreateObject("Scripting.Dictionary")
    Sheet2.Activate
    Arr = Sheet1.[a1].CurrentRegion
    For i = 2 To UBound(Arr)
        s = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3) & "|" & Arr(i, 4)
        If Not d.exists(s) Then
            d(s) = Array(Arr(i, 5), i)
        Else
            a = d(s)
            If Arr(i, 5) > a(0) Then
                a(0) = Arr(i, 5): a(1) = i: d(s) = a
            End If
        End If
    Next
    Brr = [a1].CurrentRegion
    For i = 2 To UBound(Brr)
        x = Brr(i, 1) & "|" & Brr(i, 2) & "|" & Brr(i, 3) & "|" & Brr(i, 4)
        If d.exists(x) Then Cells(i, 5).Resize(1, 2) = d(x)
    Next
End Sub

Chip_Kenny

try this:
Sub zz()
Dim a, d As Object, k, t, b()
Set d = CreateObject("scripting.dictionary")
a = Sheets(1).[a1].CurrentRegion.Value
For i = 2 To UBound(a)
    k = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If d.exists(k) Then
        t = d(k): t(0) = IIf(t(0) > a(i, 5), t(0), a(i, 5))
        d(k) = Array(t(0), i)
    Else
        d(k) = Array(a(i, 5), i)
    End If
Next
a = Sheets(2).[a1].CurrentRegion.Value
ReDim b(1 To UBound(a) - 1, 1 To 2)
For i = 2 To UBound(a)
    k = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    b(i - 1, 1) = d(k)(0): b(i - 1, 2) = d(k)(1)
Next
Sheets(2).[e2].Resize(UBound(b), 2) = b
End Sub

zax010

VBA多条件查询0717 - 副本.rar (17.12 KB, 下载次数: 37)

2017-3-6 12:58 上传

点击文件名下载附件

bosao

zhangzhang 发表于 2017-3-6 12:42
详见附件〉〉〉〉〉〉〉〉〉〉

谢谢，但当最大值在符合条件的所有行上方时，返回错误数据

bosao

VBA多条件查询-Chip_Kenny - 副本.rar (19.37 KB, 下载次数: 8)

2017-3-6 16:03 上传

点击文件名下载附件

Chip_Kenny 发表于 2017-3-6 12:58
try this:
Sub zz()
Dim a, d As Object, k, t, b()

谢谢，返回最大值正确，但行号有错误

bosao

zax010 发表于 2017-3-6 12:58

谢谢，看不太懂局部，能否再次劳驾讲解
Private Sub CommandButton1_Click()
    Dim Arr, i&, Brr, d
    Set d = CreateObject("Scripting.Dictionary")    '创建字典，并赋予对象d
    Sheet3.Activate                                 '激活表3
    Arr = Sheet1.[a1].CurrentRegion                 'A1所在区域赋予数组Arr
    For i = 2 To UBound(Arr)
        s = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3) & "|" & Arr(i, 4)     '数组中1~4列文本连接，结果赋值于变量s
        If Not d.exists(s) Then                     '如果字典中不存在变量s则
            d(s) = Array(Arr(i, 5), i)              '变量s写入字典，其项为数组（区域第5列的值和行号）
        Else                                        '如果变量存在于字典中则
            a = d(s)                                '将字典中变量s的项赋予变量a
            If Arr(i, 5) > a(0) Then                '如果变量s所在行的第5列值大于变量a（字典中已存在的项）
                a(0) = Arr(i, 5): a(1) = i: d(s) = a       '？
            End If
        End If
    Next
    Brr = [a1].CurrentRegion                        '条件区域赋予数组Brr
    For i = 2 To UBound(Brr)
        x = Brr(i, 1) & "|" & Brr(i, 2) & "|" & Brr(i, 3) & "|" & Brr(i, 4)       '条件数组中1~4列文本连接，结果赋值于变量x
        If d.exists(x) Then Cells(i, 5).Resize(1, 2) = d(x)          '如果变量x存在于字典中则调整该行第5列区域大小并赋值该变量对应的项（数组）
    Next
End Sub

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("订单")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a1:e" & r)
   
9.     For i = 2 To UBound(arr)
   
10.       xm = arr(i, 1) & "+" & arr(i, 2) & "+" & arr(i, 3) & "+" & arr(i, 4)
    
11.       If Not d.exists(xm) Then
    
12.         ReDim brr(1 To 6)
    
13.         For j = 1 To 5
    
14.           brr(j) = arr(i, j)
    
15.         Next
    
16.         brr(6) = i
    
17.       Else
    
18.         brr = d(xm)
    
19.         If arr(i, 5) > brr(5) Then
    
20.           brr(5) = arr(i, 5)
    
21.           brr(6) = i
    
22.         End If
    
23.       End If
    
24.       d(xm) = brr
    
25.     Next
    
26.   End With
    
27.   With Worksheets("校对")
    
28.     .UsedRange.Offset(1, 0).Clear
    
29.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
30.   End With
    
31. End Sub
    

复制代码