求助用VBA查询 对应的数据

zhangwg0604

想要的效果

填 入条件1和条件2查询数据源中对应的日期和销售数据
用VBA 如何实现
感谢各位老师。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2025.1.15
   
2.     Application.ScreenUpdating = False
   
3.     arr = Sheets("数据源").UsedRange
   
4.     ReDim brr(1 To 1000, 1 To 2)
   
5.     ReDim crr(1 To 1000, 1 To 2)
   
6.     With Sheets("Sheet2")
   
7.         .[a7].Resize(1000, 4) = Empty
   
8.         xm1 = .[b3].Value: xm2 = .[d3].Value
   
9.         rq1 = .[b4].Value: rq2 = .[d4].Value
   
10.         m1 = .[b5].Value: m2 = .[d5].Value
    
11.         For i = 2 To UBound(arr)
    
12.             If arr(i, 2) >= rq1 Then
    
13.                 If arr(i, 3) = xm1 Then
    
14.                     m = m + 1
    
15.                     brr(m, 1) = arr(i, 2)
    
16.                     brr(m, 2) = arr(i, 6)
    
17.                     If m = m1 Then Exit For
    
18.                 End If
    
19.             End If
    
20.         Next
    
21.         For i = 2 To UBound(arr)
    
22.             If arr(i, 2) >= rq2 Then
    
23.                 If arr(i, 3) = xm2 Then
    
24.                     n = n + 1
    
25.                     crr(n, 1) = arr(i, 2)
    
26.                     crr(n, 2) = arr(i, 6)
    
27.                     If n = m2 Then Exit For
    
28.                 End If
    
29.             End If
    
30.         Next
    
31.         .[a7].Resize(m1, 2) = brr
    
32.         .[c7].Resize(m2, 2) = crr
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "OK！"
    
36. End Sub
    
37. 
    

复制代码

zhangwg0604

ykcbf1100 发表于 2025-1-15 14:58
参与一下。。。

感谢大神的帮助。代码完美实现！
如果后面的差异列也用代码就更完美。
我用你的方法加了一个for 循环 差异可以自动填入了！非常感谢
Sub ykcbf()    '//2025.1.15
    Application.ScreenUpdating = False
    arr = Sheets("数据源").UsedRange
    ReDim brr(1 To 1000, 1 To 2)
    ReDim crr(1 To 1000, 1 To 2)
    ReDim drr(1 To 1000, 1 To 2)
    With Sheets("Sheet2")
        .[a7].Resize(1000, 4) = Empty
        xm1 = .[b3].Value: xm2 = .[d3].Value
        rq1 = .[b4].Value: rq2 = .[d4].Value
        m1 = .[b5].Value: m2 = .[d5].Value
      If m1 <= 0 Or m2 <= 0 Then Exit Sub '避免天数小于等于0
        For i = 2 To UBound(arr)
            If arr(i, 2) >= rq1 Then
                If arr(i, 3) = xm1 Then
                    m = m + 1
                    brr(m, 1) = arr(i, 2)
                    brr(m, 2) = arr(i, 6)
                    If m = m1 Then Exit For
                End If
            End If
        Next
        For i = 2 To UBound(arr)
            If arr(i, 2) >= rq2 Then
                If arr(i, 3) = xm2 Then
                    n = n + 1
                    crr(n, 1) = arr(i, 2)
                    crr(n, 2) = arr(i, 6)
                    If n = m2 Then Exit For
                End If
            End If
        Next
       For i = 1 To m1
            y = y + 1
            drr(y, 1) = crr(i, 2) - brr(i, 2)
            If y = m1 Then Exit For
            
        Next
        .[a7].Resize(m1, 2) = brr
        .[c7].Resize(m2, 2) = crr
        .[E7].Resize(m1, 1) = drr
    End With
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub