2笔相同数据

cmo9020

各位大神们好，
请问一下Sheet2 料名对应TEST工作表

可是为什么我2笔相同数据代码20494-0000981，COPY到Sheet2后...
数量显示都是20
答案应该是一笔100，一笔20
请导师们帮忙修改一下代码，谢谢导师们


Option Explicit

Sub d_m()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

    Dim db, arr, i, drr, j, crr, k, rlt
    Set db = CreateObject("Scripting.Dictionary")
    arr = Sheets("test").UsedRange
    For i = 2 To UBound(arr)
        db(Trim(arr(i, 1))) = Trim(arr(i, 2))
    Next i
    arr = Sheets("Sheet2").UsedRange
    ReDim rlt(2 To UBound(arr), 1 To 1)
    For i = 2 To UBound(arr)
        If db.Exists(Trim(arr(i, 2))) Then rlt(i, 1) = db(Trim(arr(i, 2)))
    Next i
    Sheets("Sheet2").Range("c2").Resize(UBound(rlt) - 1, 1) = rlt



        Set db = CreateObject("Scripting.Dictionary")
    crr = Sheets("test").UsedRange
    For k = 1 To UBound(crr)
        db(Trim(crr(k, 1))) = Trim(crr(k, 3))

            Next k
    crr = Sheets("Sheet2").UsedRange
    ReDim rlt(2 To UBound(crr), 1 To 1)
    For k = 1 To UBound(crr)
        If db.Exists(Trim(crr(k, 2))) Then rlt(k, 1) = db(Trim(crr(k, 2)))
    Next k
       Sheets("Sheet2").Range("d2").Resize(UBound(rlt) - 1, 1) = rlt


       Set db = CreateObject("Scripting.Dictionary")
        drr = Sheets("test").UsedRange
        For j = 2 To UBound(drr)
        db(Trim(drr(j, 1))) = Trim(drr(j, 4))
    Next j

    drr = Sheets("Sheet2").UsedRange
    ReDim rlt(2 To UBound(drr), 1 To 1)
    For j = 2 To UBound(drr)
        If db.Exists(Trim(drr(j, 2))) Then rlt(j, 1) = db(Trim(drr(j, 2)))
    Next j
       Sheets("Sheet2").Range("e2").Resize(UBound(rlt) - 1, 1) = rlt



Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub

捞屎人

好像不复杂的问题   都是看了你的代码 就变得复杂了  

cmo9020

捞屎人 发表于 2022-11-21 21:27
好像不复杂的问题   都是看了你的代码 就变得复杂了

哈哈哈...过奖...不太会只能一直东凑西拼找答案

lcluck2002

的确感觉代码是把简单的问题弄得复杂了。

cmo9020

lcluck2002 发表于 2022-11-21 22:20
的确感觉代码是把简单的问题弄得复杂了。

那我在找找其他答案