vba查找最近的数据

waw751115

请教大侠们：怎样根据表里要求查找时间最近的那个手机号。

shiruiqiang

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        If CBool(Len(ar(i, 3))) And CBool(Len(ar(i, 4))) Then
            If Not dic.exists(ar(i, 4)) Then
                dic(ar(i, 4)) = ar(i, 3)
            End If
        End If
    Next i
   
    [I1].CurrentRegion.Offset(1).Clear
    With [I2].Resize(dic.Count, 2)
        .NumberFormatLocal = "@"
        .Value = Application.Transpose(Array(dic.keys, dic.items))
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

3190496160

Sub 查询()
Dim ar As Variant
Dim br(), cr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 1).End(xlUp).Row
ar = Range("a1:d" & r)
For i = 2 To UBound(ar)
    If ar(i, 4) <> "" Then
        w = ar(i, 4)
        If Not d.exists(w) Then Set d(w) = CreateObject("scripting.dictionary")
        d(w)(i) = d(w)(i) + 1
    End If
Next i
ReDim cr(1 To d.Count, 1 To 2)
For Each k In d.keys
    m = m + 1
    sl = d(k).Count
    x = d(k).keys
    cr(m, 1) = k
    If sl = 1 Then
        cr(m, 2) = ar(x(0), 3)
    Else
        ks = CDate(Format(ar(x(0), 2), "yyyy/m/d"))
        For Each kk In d(k).keys
            If ar(kk, 3) <> "" Then
                rq = CDate(Format(ar(kk, 2), "yyyy/m/d"))
                If rq <= ks Then
                    hm = ar(kk, 3)
                Else
                    hm = ar(x(0), 3)
                End If
            End If
        Next kk
        cr(m, 2) = hm
    End If
Next k
[i1].CurrentRegion.Offset(1) = Empty
[i2].Resize(m, 2) = cr
MsgBox "ok!"
End Sub

3190496160

123.rar (70.38 KB, 下载次数: 4)

2024-10-1 09:53 上传

点击文件名下载附件

waw751115

gwjkkkkk 发表于 2024-10-1 09:36
参与一下。。。

谢谢，国庆快乐！

ZHLK

Sub demo()
Dim cnn As Object, rst As Object
Dim strPath As String, strCnn As String, strSQL As String
Dim i As Long
Set cnn = CreateObject("adodb.connection")
strPath = ThisWorkbook.FullName
strCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & strPath
cnn.Open strCnn
strSQL = "SELECT 车牌号,手机号"
strSQL = strSQL & " FROM [sheet1$a1:d1195]"
strSQL = strSQL & " GROUP BY 车牌号, 手机号, 时间"
strSQL = strSQL & " HAVING (((时间) In (SELECT Max(时间) FROM [sheet1$a1:d1195])))"
Set rst = cnn.Execute(strSQL)

Range("i2").CopyFromRecordset rst

cnn.Close
Set cnn = Nothing
End Sub

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 2 To UBound(arr)
        If Len(arr(i, 4)) <> 0 Then
            If Not d.exists(arr(i, 4)) Then
                n = n + 1
                d(arr(i, 4)) = n
                brr(n, 1) = arr(i, 4)
                brr(n, 3) = CDate(arr(i, 2))
                brr(n, 2) = arr(i, 3)
            Else
                m = d(arr(i, 4))
                If brr(m, 3) < CDate(arr(i, 2)) Then
                    brr(m, 3) = CDate(arr(i, 2))
                    brr(m, 2) = arr(i, 3)
                End If
            End If
        End If
    Next
    With Sheet1
        .[i1].CurrentRegion.ClearContents
        .[i1:j1] = [{"车牌号","手机号"}]
        .[i2].Resize(n, 2) = brr
    End With
    Set d = Nothing
    Beep
End Sub