[發問] 跨2工作表查詢比對後呈述成1工作表資料

BV7BW

各位先進 老師 大家好

請教各位先進 老師
問題需求
跨2工作表查詢比對後呈述成1工作表資料
以日期K5.K6(111/08/01至111/08/09止)
至(訂貨明細表)中比對.同項目則須加成總和
呈列A2:D2各項資料
E2(庫存)則須至(項目編號)庫存如O4:O103
至KS4:KS103中比對資料
或至(項目編號)NN2至NN2639中比對資料
呈現出E2(庫存)資料
例以下是查詢比對後結果

samwang

各位先進 老師 大家好

請教各位先進 老師
問題需求
跨2工作表查詢比對後呈述成1工作表資料
以日期K5. ...
BV7BW 發表於 2022-8-19 14:05

請測試看看，謝謝
Sub 日期總量查詢()
Dim Arr, xD, T$, Ds As Date, De As Date, i&, j%, n&
Set xD = CreateObject("Scripting.Dictionary")
Ds = [K5]: De = [K6]
Arr = Sheets("訂貨明細表").[a1].CurrentRegion
ReDim Crr(1 To UBound(Arr), 1 To 5)
For i = 2 To UBound(Arr)
    If Arr(i, 12) >= Ds And Arr(i, 12) <= De Then
        T = Arr(i, 4)
        If xD.Exists(T) Then
            Crr(xD(T), 3) = Crr(xD(T), 3) + Arr(i, 5)
        Else
            n = n + 1: xD(T) = n
            For j = 3 To 6: Crr(n, j - 2) = Arr(i, j): Next
        End If
    End If
Next
With Sheets("項目編號")
    Arr = .Range("F3").CurrentRegion
    For j = 6 To UBound(Arr, 2) Step 10
        For i = 4 To UBound(Arr)
            T = Arr(i, j): If T = "" Then GoTo 91
            xD(T) = Arr(i, j + 9)
91:     Next
    Next
End With
For i = 1 To n: Crr(i, 5) = xD(Crr(i, 1) & ""): Next
If n > 0 Then
    Range("a2:e1000") = ""
    Range("a2").Resize(n, 5) = Crr
End If
End Sub

BV7BW

回復 2# samwang
samwang 老師 你好

經測試已非常正確符合需求.庫存資料也正確登錄

謝謝   samwang 老師 指導

庫存部分是否在上提文中修改
Sub 單項目查詢()
'程式資料來源至sanwanq2022-7-29 指導
Dim Arr, xD, T$, Ds As Date, De As Date
Dim Brr(1 To 1, 1 To 4), Crr(), n%, i&, j%
Range("R2:V12").Select
    Selection.ClearContents
    Range("A2:E1500").Select
    Selection.ClearContents
    Range("Q2:V300").Select
    Selection.ClearContents
    'Range("O2:O100").Select
    'Selection.ClearContents
    Range("K7").Select
Set xD = CreateObject("Scripting.Dictionary")
Ds = [K5]: De = [K6]: T = [K9]
Arr = Sheets("訂貨明細表").[a1].CurrentRegion
ReDim Crr(1 To UBound(Arr), 1 To 5)
For i = 2 To UBound(Arr)
    If Arr(i, 4) <> T Then GoTo 99
    If Arr(i, 12) >= Ds And Arr(i, 12) <= De Then
        If n = 0 Then
            n = n + 1: xD(Arr(i, 1) & "") = n
            For j = 1 To 4: Brr(1, j) = Arr(i, j + 2): Next
            Crr(n, 1) = Arr(i, 1): Crr(n, 2) = Arr(i, 3)
            Crr(n, 3) = Arr(i, 4): Crr(n, 4) = Arr(i, 5)
            Crr(n, 5) = Arr(i, 6)
        Else
            If xD.Exists(Arr(i, 1) & "") Then
                m = xD(Arr(i, 1) & "")
                Crr(m, 4) = Arr(i, 5) + Crr(m, 4)
            Else
                n = n + 1: xD(Arr(i, 1) & "") = n
                Crr(n, 1) = Arr(i, 1): Crr(n, 2) = Arr(i, 3)
                Crr(n, 3) = Arr(i, 4): Crr(n, 4) = Arr(i, 5)
                Crr(n, 5) = Arr(i, 6)
            End If
            Brr(1, 3) = Brr(1, 3) + Arr(i, 5)
        End If
    End If
99: Next
If n > 0 Then
    Range("a2:c2") = ""
    Range("a2").Resize(1, 4) = Brr
    Range("r2:v8") = ""
    Range("r2").Resize(n, 5) = Crr
End If
With ActiveSheet
    Beep
End With
End Sub

samwang

回復  samwang
samwang 老師 你好

經測試已非常正確符合需求.庫存資料也正確登錄

謝謝   samwang 老 ...
BV7BW 發表於 2022-8-22 14:04

庫存部分是否在上提文中修改 >> 請問這是什麼意思
另外，為何你修改3樓程式碼和2樓不一樣，需求為何? 請確認，謝謝

BV7BW

回復 4# samwang
samwang 老師 你好


本提問中以完全正確運作正常

抱歉說明問題表達文辭不好

我是以上次提問中(單項目查詢)sanwanq老師2022-7-29指導中(正常運作中)
跟這次提問是有所相關(庫存)問題是相同
是想這次題問中庫存部分是否也能套入到(單項目查詢)中(庫存)問題

Sub 單項目查詢()sanwanq老師2022-7-29指導中(正常運作)之結果
項編        項目名稱        數量               單位             庫存
A101           你1                 12                台斤
       
Sub 日期總量查詢()sanwanq老師2022-08-19 指導中(正常運作中)之結果
項編        項目名稱        數量               單位                 庫存
A101           你1                 12               台斤                   1
A102           我1                  2               台斤                   1
A103           他1                  2               公斤                   1
....
....