Vergelijk van twee bestanden en verschil toevoegen aan 1 bestand

[Nieuwenhuizen]

Hallo,

Ik heb twee bestanden met relatiegegevens en wil afwijkende relaties in 1 bestand automatisch in kleur toevoegen.

Dus;
Voorbeeldbestand 1.xls is voorzien van twee regels (relatie 8 en 1) vergelijken met bestand 2.xls voorzien van 3 regels (relatie 8, 3 en 1) en de uitzondering relatie 3 toevoegen in kleur in bestand 1.xls.

Wie kan helpen ?

Groetjes,

Frank.

 

[Demeter]

Frank,

Heb weinig tijd op het moment op iets te proberen.
Denk dat je met een zoek opdracht moet werken. Deze veerwerk je in een loop waarin je ieder getal in map 2 afgaat en controleerd aan map 1. Bestaat deze niet in je breik in map1 dan laat je hem over zetten.


Groet,
Ferenc

 

[Wigi]

Deze veerwerk je in een loop waarin je ieder getal in map 2 afgaat en controleerd aan map 1.

Gebruik een COUNTIF functie in VBA.

 

[Demeter]

Mmmmmmmm, even snel geprobeert:

Sub overzetten()
Dim c As Range
Dim laatsteregel As Long
Dim legeregel As Long
Dim zoekopdracht As Long

laatsteregel = Workbooks("2.xls").Sheets("Blad1").Range("A65536").End(xlUp).Row

For Each c In Workbooks("2.xls").Sheets("Blad1").Range("A3:A" & laatsteregel)
    If c <> "" Then
        If WorksheetFunction.CountIf(Workbooks("1.xls").Sheets("Blad1").Range("A3:A17"), c) = 0 Then
            legeregel = Workbooks("1.xls").Sheets("Blad1").Range("A" & Workbooks("1.xls").Sheets("Blad1").Range("A65536").End(xlUp).Row + 1)
            Workbooks("2.xls").Sheets("Blad1").Range("A" & c.Row, "E" & c.Row).Copy Workbooks("1.xls").Sheets("Blad1").Range("A" & legeregel)
        End If
    End If
Next

End Sub

Zou moeten werken mits je de legeregel aan de praat krijgt. Beats me.

Groet,
Ferenc

ps.
Code kan denk nog wel wat korter, misschien kom ik daar vanavond op terug.

 

[Wigi]

ps.
Code kan denk nog wel wat korter, misschien kom ik daar vanavond op terug.

Ik kon me niet bedwingen... hehe...

Sub overzetten()
Dim c As Range, lLastRow1 As Long, lLastRow2 As Long, rngBereik1 As Range, rngBereik2 As Range, lCount As Long

With Workbooks("1.xls").Sheets("Blad1")
    lLastRow1 = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngBereik1 = .Range("A3:A" & lLastRow1)
End With

With Workbooks("2.xls").Sheets("Blad1")
    lLastRow2 = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngBereik2 = .Range("A3:A" & lLastRow2)
End With

lCount = 0
For Each c In rngBereik2
    If c <> "" Then
        If WorksheetFunction.CountIf(rngBereik1, c) = 0 Then
            lCount = lCount + 1
            With Workbooks("1.xls").Sheets("Blad1").Range("A" & lLastRow1 + lCount)
                c.Resize(, 5).Copy .Range("A1")
                .Resize(, 5).Interior.ColorIndex = 3
            End With
        End If
    End If
Next
MsgBox "Ready"
End Sub

Wigi

 

[Nieuwenhuizen]

Bedankt

Bedankt !! :thumb: :thumb: Prima geholpen, en het WERKT !!!!

 

[Wigi]

Bedankt !! :thumb: :thumb: Prima geholpen, en het WERKT !!!!

OK graag gedaan, zijn wij ook blij.

 

[Demeter]

Wigi,

Bedankt voor jecode .
Vindt de ICount oplossing een mooie om te onthouden.

Groet,
Ferenc

 

[Wigi]

Wigi,

Bedankt voor jecode .
Vindt de ICount oplossing een mooie om te onthouden.

Groet,
Ferenc

Nu ik mijn oplossing zo teruglees, denk ik dat het veel beter kan door gewoon:

1. bereik2 te kopiëren onder bereik1
2. het grote bereik van dubbelen te ontdoen met een advanced filter

Veel sneller klaar dan de eerste methode als er veel rijen te vergelijken zijn. Bij weinig rijen is het verschil niet te merken.

Anyway, wou dat maar eens laten weten.

Wigi