根据多条件查找对应内容

luoshb2003

由于数据条数多，达到二三十万条以上，求助：
通过点击宏执行，根据“表1”的代码1、代码2、时间字段，到“明细表”中查找和获取符合条件的归属类别字段内容。
详见附件，谢谢。

luoshb2003

不知道是不是我的需求没说清楚，有前辈帮忙吗

lsc900707

考虑SQL或者字典。

alstar

Sub 按钮1_Click()
Dim arr1()
R = Cells(Rows.Count, "G").End(xlUp).Row
R1 = Sheets("明细表").Cells(Rows.Count, "B").End(xlUp).Row
ARR = Application.Transpose(Array(Application.Transpose(Range("G3:G" & R)), Application.Transpose(Range("M3:M" & R)), Application.Transpose(Range("X3:X" & R))))
With Sheets("明细表")
BRR = Application.Transpose(Array(Application.Transpose(.Range("B2:B" & R1)), Application.Transpose(.Range("C2:C" & R1)), Application.Transpose(.Range("F2:F" & R1)), Application.Transpose(.Range("H2:H" & R1)), Application.Transpose(.Range("R2:R" & R1))))
End With
For I = 1 To UBound(ARR)
n = n + 1
ReDim Preserve arr1(1 To n)
    For II = 1 To UBound(BRR)
        If ARR(I, 1) = BRR(II, 3) And ARR(I, 2) = BRR(II, 4) And ARR(I, 3) >= BRR(II, 1) And ARR(I, 3) <= BRR(II, 2) Then
            arr1(n) = BRR(II, 5)
        End If
    Next
Next
[Y3].Resize(UBound(arr1)) = Application.Transpose(arr1)
End Sub

alstar

模板9.29.rar (273.7 KB, 下载次数: 144)

2018-9-29 20:00 上传

点击文件名下载附件

请参考。

alstar

1. Sub 按钮1_Click()
   
2. Dim arr1()
   
3. Dim brr, arr, r%, r1%, n%, i%, ii%
   
4. timesr = Timer
   
5. r = Cells(Rows.Count, "G").End(xlUp).Row
   
6. r1 = Sheets("明细表").Cells(Rows.Count, "B").End(xlUp).Row
   
7. arr = Application.Transpose(Array(Application.Transpose(Range("G3:G" & r)), Application.Transpose(Range("M3:M" & r)), Application.Transpose(Range("X3:X" & r))))
   
8. With Sheets("明细表")
   
9. brr = Application.Transpose(Array(Application.Transpose(.Range("B2:B" & r1)), Application.Transpose(.Range("C2:C" & r1)), Application.Transpose(.Range("F2:F" & r1)), Application.Transpose(.Range("H2:H" & r1)), Application.Transpose(.Range("R2:R" & r1))))
   
10. End With
    
11. For i = 1 To UBound(arr)
    
12. n = n + 1
    
13. ReDim Preserve arr1(1 To n)
    
14.     For ii = 1 To UBound(brr)
    
15.         If arr(i, 1) = brr(ii, 3) And arr(i, 2) = brr(ii, 4) And arr(i, 3) >= brr(ii, 1) And arr(i, 3) <= brr(ii, 2) Then
    
16.             arr1(n) = brr(ii, 5)
    
17.         End If
    
18.     Next
    
19. Next
    
20. Range("Y3:Y" & r).ClearContents
    
21. [Y3].Resize(UBound(arr1)) = Application.Transpose(arr1)
    
22. MsgBox UBound(arr1) & "行数据生成完毕" & Chr(10) & "用时:" & Format(Timer - timesr, "0.0") & "秒"
    
23. End Sub

复制代码

excelvlookup

如果代码1三位数，代码2三位数，这个比字典快
Sub 按钮1_Click()
rw = Sheets("明细表").Cells(Rows.Count, 1).End(3).Row
ar = Sheets("明细表").Range("b2:r" & rw)
rrw = Sheets("表1").Cells(Rows.Count, 1).End(3).Row
arr = Sheets("表1").Range("g3:x" & rrw)
ReDim br(999, 999)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(ar)
    a1 = Val(ar(i, 5)): a2 = Val(ar(i, 7))
    br(a1, a2) = br(a1, a2) & "|" & ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 17)
Next
For i = 1 To UBound(arr)
    b = br(Val(arr(i, 1)), Val(arr(i, 7)))
    If b <> "" Then
        x = Split(b, "|")
        For j = 1 To UBound(x)
            t = Split(x(j), ",")
            If arr(i, 18) >= Val(t(0)) And arr(i, 18) <= Val(t(1)) Then
                brr(i, 1) = t(2)
                Exit For
            End If
        Next
    End If
Next
Sheets("表1").Range("z3").Resize(UBound(brr), 1) = brr
End Sub

luoshb2003

alstar 发表于 2018-9-29 20:00
请参考。

谢谢帮助，解决了问题。

luoshb2003

excelvlookup 发表于 2018-9-29 21:00
如果代码1三位数，代码2三位数，这个比字典快
Sub 按钮1_Click()
rw = Sheets("明细表").Cells(Rows.Coun ...

感谢帮助，代码是3至4位数

luoshb2003

excelvlookup 发表于 2018-9-29 21:00
如果代码1三位数，代码2三位数，这个比字典快
Sub 按钮1_Click()
rw = Sheets("明细表").Cells(Rows.Coun ...

代码是3至4位数，试一下出现4位数的时候就报错了