关于vba字典查不到的问题

hfq20052006

我想使用VBA的字典对下表根据订单号进行筛选，只保留不重复的订单号，重复的订单号使用较大的交付日期

为什么使用字典查询后没有去除掉订单号重复的记录，查询后的输出见下图（要求的结果是变色记录只保留1条）


使用的代码为
Sub 按钮01_Click()
    Dim 棋盘(1 To 1000, 1 To 2)
    Dim 行数
    Dim arr, r, x, k
    Dim d As New Dictionary

    With Sheets("sheet1")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A2:B" & r).Value
    End With

    For x = 1 To UBound(arr)
        If d.Exists(arr(x, 1)) Then
            行数 = d(arr(x, 1))
            If arr(x, 2) = "" Then
                棋盘(行数, 2) = Date + 1
            ElseIf arr(x, 2) > 棋盘(行数, 2) Then
               棋盘(行数, 2) = arr(x, 2)
            End If
        Else
            k = k + 1
            棋盘(k, 1) = arr(x, 1)
            棋盘(k, 2) = arr(x, 2)
         End If
    Next x
    Sheets("sheet2").Range("A2").Resize(k, 2) = 棋盘
End Sub


求高手解答，谢谢！

microyip

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Offset(1).Value
  For i = 1 To UBound(arr, 1) - 1
    If dic.Exists(arr(i, 1)) Then
      If arr(i, 2) > arr(dic(arr(i, 1)), 2) Then arr(dic(arr(i, 1)), 2) = arr(i, 2)
    Else
      m = m + 1: dic(arr(i, 1)) = m
      For j = 1 To UBound(arr, 2)
        arr(m, j) = arr(i, j)
      Next
    End If
  Next
  With Sheets("sheet2").[a2]
    .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    .Resize(m, UBound(arr, 2)) = arr
  End With
End Sub

xiexl

你的字典没有写入任何key，所以你的程序全部执行的是else，结果就是和原来完全一样。

hfq20052006

microyip 发表于 2020-3-28 13:15

当字典不存在时，应该添加字典啊，难道不是吗？求解答

xiexl

   Else
            k = k + 1
            棋盘(k, 1) = arr(x, 1)
            棋盘(k, 2) = arr(x, 2)
加上这句   d(arr(x, 1))=k
应该可以实现，我在手机上看的，没有调试，你自己试一试。

microyip

hfq20052006 发表于 2020-3-28 13:59
当字典不存在时，应该添加字典啊，难道不是吗？求解答

那么你添加字典的语句在哪呢？

hfq20052006

感谢各位高手的解答，以上方法均可，再次感谢！