VBA data kopiëren op basis van meerdere voorwaarden

[dpey]

Goedemorgen,

Ik zou graag data willen kopiëren van het ene naar het andere blad indien deze voldoet aan bepaalde voorwaarden (met behulp van VBA)

In de bijlage heb ik een werkblad toegevoegd ik hoop dat ik hiermee mijn vraag kan verduidelijken:

Op het tabblad data heb ik 3 kolommen gevuld: Nummer, Subnummer en Soort
Op het tabblad "Output" wil ik graag een nummer invoeren waarna enkel de rijen van het blad "Data" gekopieerd worden naar het blad Output waarbij het nummer overeenkomt en waarbij de "Soort" gelijk is aan A.
Indien het nummer overeenkomt, maar de soort gelijk is aan B, dan zal het bijbehorende subnummer gezocht moeten worden in de kolom "Nummer". Ook dan zullen alleen de rijen gekopieerd moeten worden indien de soort gelijk is aan A, etc. etc.

In het tabblad "Output (voorbeeld)"heb ik de output geplaatst die ik wil bereiken als ik bijvoorbeeld nummer 1000 of nummer 5000 opgeef.

Ik hoop dat het duidelijk is, maar kan begrijpen als jullie nog vragen hebben

Bekijk bijlage Voorbeeld.xlsx

 

[VenA]

Wat is het verschil met deze vraag? http://www.worksheet.nl/forumexcel/vragen/84373-rijen-op-basis-van-meerdere-voorwaarden-kopi%EBren-naar-ander-werkblad.html#post681365

 

[snb]

En gebruik autofilter of uitgebreid filter.

 

[dpey]

Wat is het verschil met deze vraag? http://www.worksheet.nl/forumexcel/vragen/84373-rijen-op-basis-van-meerdere-voorwaarden-kopi%EBren-naar-ander-werkblad.html#post681365

Het verschil is dat ik met dit voorbeeld een niveau dieper wilt gaan:
als het soort B is, dan moet ik het "subnummer" zoeken in de kolom "nummer" en de bijbehorende subnummers van het soort A tonen.
Zover reikt mijn VBA kennis helaas niet.


Het is me helaas niet gelukt om dit via een filter te realiseren.

 

[dpey]

Via onderstaande code lukt het bijna. Hier zou hij alleen nog stap 2 en 3 moeten herhalen zodat hij alle subnummers gaat zoeken in kolom A. Met onderstaande code zoekt hij er slechts 1

Sub copy()

'1. zoek nummer
With Sheets("Output")
.Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Data").Range("A:A").SpecialCells(2)
If cl.Value = Sheets("Output").Range("B1").Value Then
If cl.Offset(0, 2).Value = "A" Then
cl.EntireRow.copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
End If
Next
End With

'2. declareer subnummer
With Sheets("Output")
For Each cl In Sheets("Data").Range("A:A").SpecialCells(2)
If cl.Value = Sheets("Output").Range("B1").Value Then
If cl.Offset(0, 2).Value = "B" Then
subnummer = cl.Offset(0, 1).Value
End If
End If
Next
End With

'3. zoek subnummer
With Sheets("Output")
For Each cl In Sheets("Data").Range("A:A").SpecialCells(2)
If cl.Value = subnummer Then
If cl.Offset(0, 2).Value = "A" Then
cl.EntireRow.copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
End If
Next
End With

End Sub

 

[snb]

In de richting:

Sub M_snb()
    With Blad1.Cells(1).CurrentRegion.Resize(, 2)
       .AutoFilter 1, 1000
       .Offset(1).Copy Blad2.Cells(1, 10)
       .AutoFilter
       For Each cl In Blad2.Columns(11).SpecialCells(2)
          .AutoFilter 1, cl.Value
          If .Columns(1).SpecialCells(12).Count > 1 Then .Offset(1).Copy Blad2.Cells(Rows.Count, 10).End(xlUp).Offset(1)
          .AutoFilter
       Next
    End With
End Sub

 

[dpey]

Dankjewel, dit komt inderdaad meer in de richting, maar geeft nog niet het gewenste resultaat.
In het resultaat zou hij de waarden van het soort B niet moeten laten zien.
Ook worden de nummers 2003 met bijbehorende subnummers niet getoond.


Maar ik zie wel een lichtpuntje aan het eind van de tunnel

 

[snb]

Je kunt beter 2 tabellen maken: 1 met de A gegevens en 1 met de B gegevens.

 

[dpey]

Ik krijg de data extern aangeleverd, echter het is wel een mogelijkheid om deze te "splitsen". Ik heb alleen geen idee hoe het dan verder op te pakken, maar jij wellicht wel

Ik heb het voorbeeld bestand opnieuw toegevoegd. De data heb ik nu verdeeld over 2 tabbladen.
Bekijk bijlage Voorbeeld (2).xlsx