Workbook filteren

[wall]

Geachte excellers,

Ben sinds kort met excel aan het rommelen, heb bijgevoegd (verkleind bestand, origineel gaat t om duizenden items) bestand in elkaar gezet mbv een hele lange vba code.
Wat er nog even bij zou moeten.................................

de gegevens van:
Sheet EMX
Sheet DELTA
Sheet HOME

Filteren op dubbele itemnrs, omschrijvingen, deze kopieren en plaatsen in

Sheet DUBBEL
Zodat we in 1 oogopslag kunnen zien welke items bekend zijn in alle drie de magazijnen.

Een kortere vbacode is ook altijd welkom

 

[Marcel79]

Die 1400+ regels VBA gaan me een beetje boven m'n pet, al vermoed ik dat een hoop code geschrapt kan worden omdat die over 'opmaak' gaat.

Met betrekking tot die dubbele: is iets dubbel als het 'Artikelnr' vaker dan 1x voorkomt? Of pas als de combinatie van Artikelnr en Omschrijving vaker dan 1x voorkomt?

De volgende code beschouwt iets als dubbel als het Artikelnr vaker dan één keer in de drie sheets voorkomt:

Option Explicit

Sub DubbeleZoeken()
Dim ws As Worksheet
Dim i As Long
Dim lItemCount As Long

Dim EMX As Range
Set EMX = Worksheets("EMX").Range("A:A")
Dim HOME As Range
Set HOME = Worksheets("HOME").Range("A:A")
Dim DELTA As Range
Set DELTA = Worksheets("DELTA").Range("A:A")
Dim DUBBEL As Range
Set DUBBEL = Worksheets("DUBBEL").Range("A:A")

Worksheets("DUBBEL").UsedRange.Clear 'maakt werkblad 'dubbel' leeg
Worksheets("EMX").Range("A10:L10").Copy _
    Destination:=Worksheets("DUBBEL").Range("A1")
    'kopieert koppen naar blad 'dubbel'
    
For Each ws In Worksheets
    If ws.Name <> "DUBBEL" Then
    'loopt door elk werkblad behalve het werkblad 'dubbel'
            
        For i = 1 To ws.Range("A65536").End(xlUp).Row
            If IsNumeric(ws.Range("A" & i).Value) Then
                'bekijkt elke waarde in kolom A of het een nummer betreft
                
                lItemCount = Application.WorksheetFunction.CountIf(EMX, ws.Range("A" & i).Value) _
                    + Application.WorksheetFunction.CountIf(HOME, ws.Range("A" & i).Value) _
                    + Application.WorksheetFunction.CountIf(DELTA, ws.Range("A" & i).Value)
                    'telt het aantal keren dat het Artikelnr. voorkomt in de kolommen A
                    'van alle drie de werkbladen bij elkaar
                    
                If lItemCount > 1 And _
                    Application.WorksheetFunction.CountIf(DUBBEL, _
                    ws.Range("A" & i).Value) = 0 Then
                    'er is een dubbele die nog niet genoteerd was op werkblad 'DUBBEL'
                    
                    ws.Range("A" & i, ws.Range("IV" & i).End(xlToLeft)).Copy _
                        Destination:=Worksheets("DUBBEL").Range("A65536").End(xlUp).Offset(1, 0)
                        'copieert rij naar 'DUBBEL'
                End If 'tot zover 'als er een dubbele is
            End If 'tot zover 'als de waarde in kolom A numeriek is'
        Next i 'volgende rij op het werkblad
    End If  'tot zover 'als de werkbladnaam NIET 'DUBBEL' luidt
Next ws 'op naar het volgende werkblad.
                
End Sub

Is dit wat je zoekt?

Groeten, Marcel

 

[Warme bakkertje]

@marcel
Wat klein wijzigingen aangebracht ivm te doorzoeken bereiken

 

[wall]

@marcel
Wat klein wijzigingen aangebracht ivm te doorzoeken bereiken

Bedankt jongens, formule werkt, ik heb over 3 terminals 5800 dubbele items, dus er kan her en der wat geschrapt gaan worden