Формула Excel для перекрестной ссылки 2 листа, удаления дубликатов с одного листа

Question

Это связано с

Excel / VBA. Удалите дублирующиеся строки, перекрестно ссылаясь на 2 разных листа, а затем удалите 1 строку

Не получается получить VBAработать хорошо или достаточно быстро для пары из 100 строк.

Есть ли в Excel формула для удаления дубликатов с одного листа путем перекрестных ссылок на другой лист?

Спасибо за всю вашу помощь.

Answer 1

Вы можете многое сделать с ADO и Excel.

Dim cn As Object
Dim rs As Object
Dim wb As Workbook
Dim sSQL As String
Dim sFile As String
Dim sCon As String
Dim sXLFileToProcess As String
Dim i

sXLFileToProcess = "Book1z.xls"

sFile = Workbooks(sXLFileToProcess).FullName

''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel

sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''Late binding, so no reference is needed

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open sCon

'' In this example, the column header for column F is F, see notes
'' above on field (column) names. It also assumes that the sheets to
'' be merged have the same column headers in the same order
'' It would be safer to list the column heards rather than use *.

sSQL = sSQL & "SELECT b.Key,b.b,b.c,b.d,b.e FROM [SheetB$] As B " _
            & "LEFT JOIN [SheetA$] As A " _
            & "ON B.Key=A.Key " _
            & "WHERE A.Key Is Null"

rs.Open sSQL, cn, 3, 3

Set wb = Workbooks.Add

With wb.Worksheets("Sheet1")
    For i = 1 To rs.Fields.Count
        .Cells(1, i) = rs.Fields(i - 1).Name
    Next

    .Cells(2, 1).CopyFromRecordset rs
End With

''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Answer 2

Вот гораздо более быстрое решение VBA, использующее объект словаря. Как вы можете видеть, он проходит только один раз на листе A и листе B, в то время как исходное решение имеет время выполнения, пропорциональное «числу строк в листе A» * «числу строк в листе B».

Option Explicit
Sub CleanDupes()
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim keyColA As String
    Dim keyColB As String
    Dim rngA As Range
    Dim rngB As Range
    Dim intRowCounterA As Integer
    Dim intRowCounterB As Integer

    keyColA = "A"
    keyColB = "B"

    intRowCounterA = 1
    intRowCounterB = 1

    Set wsA = Worksheets("Sheet A")
    Set wsB = Worksheets("Sheet B")

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
        Set rngA = wsA.Range(keyColA & intRowCounterA)
        If Not dict.Exists(rngA.Value) Then
            dict.Add rngA.Value, 1
        End If
        intRowCounterA = intRowCounterA + 1
    Loop

    intRowCounterB = 1
    Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
        Set rngB = wsB.Range(keyColB & intRowCounterB)
        If dict.Exists(rngB.Value) Then
             wsB.Rows(intRowCounterB).Delete
             intRowCounterB = intRowCounterB - 1
        End If
        intRowCounterB = intRowCounterB + 1
    Loop
End Sub