无法使用 VBA .find 找到日期

Question

tmpArr(1, j) 可以是日期或字符串。如果是日期，那么我需要在 Range(i4:ck4) 中找到它。此范围内的日期被格式化为日期。我下面的代码没有找到我的日期。我做错了什么？

Data 是 A 列中的代码，它是字母数字，长度可能为 3 个字符。 Tbk mnth 是 B 列，是日期。

Code    Tbk Mnth
BX      1-Oct-06
C7      1-Dec-11
C7      1-Apr-12
LA      1-Feb-15
NJ      1-Mar-15

    Dim rng As Range
    Dim tmpArr As Variant
    Dim Dict As Object, tmpDict As Object
    Dim i As Long, j As Long
    Dim v, key
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim item As Variant
    Dim d As Date

    Set Dict = CreateObject("Scripting.Dictionary")
    Set ws = Worksheets("Data")
    Set ws2 = Worksheets("Plan")
    Set ws3 = Worksheets("test")

    With ws
        Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))

        tmpArr = rng.Value

        For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
            ' Test if value exists in dictionary. If not add and set up the dictionary item
            If Not Dict.exists(tmpArr(i, 1)) Then
                Set tmpDict = Nothing
                Set tmpDict = CreateObject("Scripting.Dictionary")
                Dict.Add key:=tmpArr(i, 1), item:=tmpDict
            End If
            ' Set nested dictionary to variable to edit it
            Set tmpDict = Nothing
            Set tmpDict = Dict(tmpArr(i, 1))

            ' Test if value exists in nested Dictionary, add if not and initiate counter
            If Not tmpDict.exists(tmpArr(i, 2)) Then
                tmpDict.Add key:=tmpArr(i, 2), item:=1
            Else
                ' Increment counter if it already exists
                tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1
            End If
            ' Write nested Dictionary back to Main dictionary
            Set Dict(tmpArr(i, 1)) = tmpDict
        Next i

        ' Repurpose array for output setting to maximum possible size (helps with speed of code)
        ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1))
        ' Set starting counters for array
        i = LBound(tmpArr, 1)
        j = LBound(tmpArr, 2)
        ' Convert dictionary and nested dictionary to flat output
        For Each key In Dict
            tmpArr(j, i) = key
            i = i + 1
            For Each v In Dict(key)
                tmpArr(j, i) = v
                tmpArr(j + 1, i) = Dict(key)(v)
                i = i + 1
            Next v
        Next key

        ' Reshape array to actual size
        ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1)
        'Change dates less than date in cell 1,9  to overdue and find the row number associated to the code
        d = ws.Cells(1, 9).Value
        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            dte = tmpArr(1, j)
            If dte < d Then
                tmpArr(1, j) = "Overdue"
                b = b + tmpArr(2, j)
            Else
                With ws2.Range("e5:e280")
                    Set c = .find(tmpArr(1, j), LookIn:=xlValues)
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        firstAddress = Mid(firstAddress, 4, 3)
                        tmpArr(2, j) = firstAddress
                    End If
                End With
            End If    
        Next j

        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            l = Len(tmpArr(1, j))
            Select Case l
            Case Is <= 3
                k = j
                rw = tmpArr(2, k)
            Case 7
                With ws2.Cells(rw, 8)
                    .Value = .Value + tmpArr(2, j)
                End With
            Case 10
                'find column for date numbers
                With ws2.Range("I4:CK4")
                    d = tmpArr(1, j)
                    Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
                    Debug.Print d
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        firstAddress = Mid(firstAddress, 4, 3)
                    End If                
                End With
            End Select
        Next j

        'See what  tmpArr looks like
        With ws3.Cells(2, 5)
            Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr)
        End With
    End With
End Sub

Answer 1

您可以使用：DateValue()，如果您的 date d 在单元格中设置为日期格式，则删除 CDate()，因为 Cdate() 用于将 String 转换为 date

Case 10
            With ws2.Range("i4:ck4")
            Dim d As Date
                d = tmpArr(1, j)
                    Set c = .find(DateValue(CDate(d)), LookIn:=xlValues, LookAt:=xlPart)
                    If Not c Is Nothing Then
                    firstAddress = c.Address
                    firstAddress = Mid(firstAddress, 4, 3)

                    End If

            End With

        End Select
    Next j

所以如果你的单元格是日期格式，可以使用这个：

Case 10
            With ws2.Range("i4:ck4")
            Dim d As Date
                d = tmpArr(1, j)
                    Set c = .find(DateValue(d), LookIn:=xlValues, LookAt:=xlPart)
                    If Not c Is Nothing Then
                    firstAddress = c.Address
                    firstAddress = Mid(firstAddress, 4, 3)

                    End If

            End With

        End Select
    Next j

编辑

Case 10
                With ws2.Range("i4:ck4")
                Dim d As Date
                    d = tmpArr(1, j)
                        Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
                        If Not c Is Nothing Then
                        firstAddress = c.Address
                        firstAddress = Mid(firstAddress, 4, 3)

                        End If

                End With

            End Select
        Next j