VBA 代码解决方案未按要求工作

Question

我想要结果，因为我在下面的屏幕截图中标记了黄色。也许有最好的解决方案，因为我试图不成功。可能会有最好的推荐方案。所以我使用的代码没有任何结果

SHEET : DBMASTER
CODE    DESCRIPTION    PRICE1   UNIT    PRICE2  UNIT2
1000    BAG R 1000 NEW  10000   YARD    15000   MTR
1001    BAG R 1001 NEW  20000   YARD    25000   MTR
1002    BAG R 1002 NEW  25000   YARD    30000   MTR

SHEET : DATADB
INV    CODE  DESCRIPTION    QTY UNIT1   REMARK             PRICE1
01-001  1000                10          READY IN BRANCH 01  
01-002  1002                15          READY IN BRANCH 01  
01-003  1000                25          READY IN BRANCH 02  
01-004  1001                12          READY IN BRANCH 03  
01-005  1000                13          READY IN BRANCH 04

OUTPUT DESIRED RESULT SHEET : DATADB
INV     CODE    DESCRIPTION     QTY UNIT1   REMARK              PRICE1
01-001  1000    BAG R 1000 NEW  10  YARD    READY IN BRANCH 01  15000
01-002  1002    BAG R 1002 NEW  15  YARD    READY IN BRANCH 01  30000
01-003  1000    BAG R 1000 NEW  25  YARD    READY IN BRANCH 02  15000
01-004  1001    BAG R 1001 NEW  12  YARD    READY IN BRANCH 03  25000
01-005  1000    BAG R 1000 NEW  13  YARD    READY IN BRANCH 04  15000

Sub trial()
Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
Dim Ary As Variant
Application.ScreenUpdating = False
With Sheets("DBMASTER")
    Source = .Range("C1").CurrentRegion.Offset(, 0).Resize(, 6)
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbBinaryCompare
For n = 2 To UBound(Source, 1)
    Dic(Source(n, 1)) = n
Next
With Sheets("DATADB")
    Ary = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value2
'update code
    ReDim Nary(1 To UBound(Ary), 1 To 5)
    For n = 1 To UBound(Ary)
         If Dic.Exists(Ary(n, 1)) Then
            Nary(n, 1) = Source(Dic(Ary(n, 1)), 2)
            Nary(n, 3) = Source(Dic(Ary(n, 1)), 4)
            Nary(n, 5) = Source(Dic(Ary(n, 1)), 3)
            End If
    Next n
 .Range("C2").Resize(UBound(Nary), 5).Value = Nary
    Application.ScreenUpdating = True
End With
End Sub

Answer 1

将CStr(Ary(n, 1))替换为Ary(n, 1)

您字典中的条目属于 Double 类型（见下图）：

但是当您使用 Dic.Exists(CStr(Ary(n, 1))) 时，您会检查 String 是否存在。因此，您需要删除 CStr.

我怀疑 VBA 是否比单元格中的 VLOOKUP 公式快。请注意，VBA 不能使用 multi-threading，因此只能使用一个 thread/core 处理器。细胞中的公式没有这种限制，因此通常更快。我建议用大量数据对其进行测试，这确实更快。

在你的代码中，问题是你的数组中有空列 Nary 所以你用数组中的空值覆盖现有值：

数组中的第 2 列和第 4 列显示 Leer，这意味着 Empty。

为避免替换

ReDim Nary(1 To UBound(Ary), 1 To 5)

和

Dim Nary() As Variant
Nary = .Range("C2").Resize(UBound(Ary), 5).Value2

在填充新数据之前将原始数据加载到数组中 Nary。所以在数组上方的那一行之后看起来像这样：

现在第 2 列和第 4 列已经 pre-filled 包含现有数据，您的循环仅填充其余部分（第 1、3 和 5 列）。

最后，所有 5 列都已填满，可以写入单元格：

我会写如下代码：

Public Sub FillData()
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("DBMASTER")
        Dim Source() As Variant
        Source = .Range("C1").CurrentRegion.Offset(, 0).Resize(, 6).Value2
    End With
    
    Dim Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    
    Dim n As Long
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next n
    
    With ThisWorkbook.Worksheets("DATADB")
        Dim Ary() As Variant
        Ary = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).Value2
        
        Dim DataRange As Range
        Set DataRange = .Range("C2").Resize(UBound(Ary), 5)
        
        Dim Nary() As Variant  ' read existing data
        Nary = DataRange.Value2
        
        For n = 1 To UBound(Ary)
             If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 2)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 4)
                Nary(n, 5) = Source(Dic(Ary(n, 1)), 3)
            End If
        Next n
        
        DataRange.Value2 = Nary
    End With
    
    Application.ScreenUpdating = True
End Sub

Answer 2

请测试下一个更新的代码。它将 return 从“I1”开始。如果 return 没问题（你需要什么），你可以覆盖初始范围（将结果放入“A1”）：

Sub trial()
 Dim n As Long, Dic As Object, Source, Ary

 With Sheets("DBMASTER")
    Source = .Range("C1").CurrentRegion.Offset(, 0).Resize(, 6)
 End With
 Set Dic = CreateObject("scripting.dictionary")
 Dic.CompareMode = vbBinaryCompare
 For n = 2 To UBound(Source, 1) 'place the necessary data in the a dict item array
    Dic(Source(n, 1)) = Array(Source(n, 2), Source(n, 4), Source(n, 5))
 Next

 With Sheets("DATADB")
    Ary = .Range("A1:G" & .Range("B" & rows.count).End(xlUp).Row).Value2
    For n = 2 To UBound(Ary)
        If Dic.Exists(Ary(n, 2)) Then
            Ary(n, 3) = Dic(Ary(n, 2))(0)
            Ary(n, 5) = Dic(Ary(n, 2))(1)
            Ary(n, 7) = Dic(Ary(n, 2))(2)
        End If
    Next n
    .Range("I1").Resize(UBound(Ary), UBound(Ary, 2)).value2 = Ary
 End With
End Sub

VBA 代码解决方案未按要求工作

VBA code solution does not work as required

arrays

excel

vba

dictionary