Excel/VBA премахва дублиращи се редове от множество листове

В момента получавам месечен дъмп от една от нашите бази данни, която съдържа всичките ни активни абонаменти за обществен транспорт. Моя задача е да ги кача в SAP, но само стойностите, които са различни в сравнение с миналия месец. Така че всички нови абонаменти трябва да бъдат взети и всички абонаменти, за които една от стойностите в една от различните колони е различна в сравнение с последния месец. Ако редът е абсолютно същият, не ми трябва.

Файлът, който получавам, съдържа 7 колони, колона A съдържа уникален ключ за служител.

Бих искал да използвам VBA, за да сравня двата файла на Excel, като поставя файла от миналия месец в Sheet1 и файла от този месец в Sheet2. Искам да намеря онези редове, които са равни, и да ги премахна от Sheet2.

Вече намерих някои примери за VBA кодове, които правят това, но нищо не изглежда да работи правилно. Това по-долу е последното, което използвах, което ми дава синтактична грешка на следващия ред от код Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value).

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
Dim strValueA As String


keyColA = "A"
keyColB = "B"

intRowCounterA = 1
intRowCounterB = 1

Set wsA = Worksheets("Sheet1")
Set wsB = Worksheets("Sheet2")

Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    intRowCounterB = 1
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    strValueA = rngA.Value
    Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value
        Set rngB = wsB.Range(keyColB & intRowCounterB)
        If strValueA = rngB.Value Then
             'Code to delete row goes here, but I'm not sure exactly'
             'what it is.'
             wsB.Range(Rows(intRowCounterB)).EntireRow.Delete
             intRowCounterB = intRowCounterB - 1
        End If
        intRowCounterB = intRowCounterB + 1
    Loop
    intRowCounterA = intRowCounterA + 1
Loop

End Sub

Някакви идеи?

Ник


duplicates excel vba
person Nick    schedule 24.04.2018    source източник
comment
Ако сте опитали код, който не работи, трябва да го включите в публикацията си и да обясните как точно не работи.   -  person Tim Williams    schedule 24.04.2018
comment
За съжаление, все още съм много нов за VBA и този сайт. Актуализирах първоначалния си въпрос.   -  person Nick    schedule 24.04.2018

Отговори (1)


arrow_upward
0
arrow_downward

Кодът по-долу намира дублирани редове от Sheet1 в Sheet2. Той сравнява всички стойности на редове в Sheet1.Row(id) concatenated с всички стойности на редове в Sheet2.Row(id) concatenated

Накрая премества дубликати в нов лист с модел на име "Sheet2 Dupes - yyyymmdd-hhmmss" (текуща дата-час)

Public Sub RemoveDuplicateRows()
    Dim ur1 As Range, ur2 As Range, dupeRows As Range
    Dim r1 As Range, s1 As String, r2 As Range, s2 As String

    Set ur1 = Worksheets("Sheet1").UsedRange.Rows
    Set ur2 = Worksheets("Sheet2").UsedRange.Rows  'Find duplicates from Sheet1 in Sheet2

    Set dupeRows = ur2(Worksheets("Sheet2").UsedRange.Rows.Count + 1)
    For Each r1 In ur1
        s1 = Join(Application.Transpose(Application.Transpose(r1)))
        For Each r2 In ur2
            s2 = Join(Application.Transpose(Application.Transpose(r2)))
            If s1 = s2 Then
                If Intersect(dupeRows, r2) Is Nothing Then
                    Set dupeRows = Union(dupeRows, r2)
                End If
            End If
        Next
    Next

    Dim wb As Workbook, wsDupes As Worksheet    'Move duplicate rows to new Sheet
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set wsDupes = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsDupes.Name = "Sheet2 Dupes - " & Format(Now, "yyyymmdd-hhmmss")
    dupeRows.Copy
    With wsDupes.Cells(1)
        .PasteSpecial xlPasteAll
        .PasteSpecial xlPasteColumnWidths
        .Select
    End With
    dupeRows.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub
person user9770531    schedule 26.04.2018
comment
Здравейте, благодаря много за отговора! Изглежда, че работи чрез изтриване на всички дубликати. Знаете ли дали е възможно да поставите разликите в нов лист, вместо да ги изтриете в Sheet2? - person Nick; 22.05.2018
comment
Здравейте, актуализирах отговора, за да преместя дублиращи се редове в нов лист - person user9770531; 24.05.2018
comment
Здравейте, вашите отзиви са много ценени. Опитах предоставения от вас код, но новият лист не се попълва и мисля, че не бях достатъчно ясен в обяснението си. Искам да запазя Sheet1 и Sheet2 такива, каквито са, и искам разликите да бъдат записани в Sheet3. Така че няма изтриване на дубликати, просто записване на уникалните стойности в Sheet3. - person Nick; 24.05.2018