求大神解决，提取10条相同数据，再去重。

zj331300

把表一中电话相同的10条数据行保留，其他的行删除，等到表二中的数据。

不知道为什么

如图，是这个意思？

不知道为什么

               

xiangbaoan

………………

iwangyi

Sub CC()
Sheet2.UsedRange.Offset(1).ClearContents
Set d = CreateObject("scripting.dictionary"): n = [f65536].End(3).Row
For i = 2 To n: d(Cells(i, "f").Value) = "": Next: kk = d.keys
For Each sjhm In kk
Set cn = CreateObject("adodb.connection"): Set RS = CreateObject("adodb.recordset")
cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= " & ThisWorkbook.FullName
Sql = "select *from [Sheet1$] where 手机号码='" & sjhm & "'"
RS.Open Sql, cn, 1, 3
If 10 = RS.RecordCount Then
rowlast = Sheet2.[a65536].End(3).Row + 1
Sheet2.Range("A" & rowlast).CopyFromRecordset cn.Execute(Sql)
End If
Next
End Sub

iwangyi

附件请参考

zj331300

iwangyi 发表于 2018-9-19 20:15
附件请参考

如果出现超过10条相同的数据无法提取，如果11条相同的数据，我只提取前10条，就大神帮忙！

zj331300

xiangbaoan 发表于 2018-9-19 16:53
………………

如果出现超过10条相同的数据无法提取，如果11条相同的数据，我只提取前10条，就大神帮忙

lsdongjh

Sub CC()
    Sheet2.UsedRange.Offset(1).ClearContents
    Set d = CreateObject("scripting.dictionary"): n = [f65536].End(3).Row
    For i = 2 To n: d(Cells(i, "f").Value) = "": Next: kk = d.keys
    strPath = ThisWorkbook.FullName
    Select Case Application.Version * 1
        Case Is <= 11
            strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
        Case Is >= 12
            strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    End Select
    Set cn = CreateObject("adodb.connection"): Set rs = CreateObject("adodb.recordset")
    cn.Open strConn
    For Each sjhm In kk
        Sql = "select Top 10 * from [Sheet1$] where 手机号码='" & sjhm & "'"
        If rs.State = 1 Then rs.Close
        rs.Open Sql, cn, 1, 3
        rowlast = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
        Sheet2.Range("A" & rowlast).CopyFromRecordset rs
    Next
End Sub

xiangbaoan

………………