Regels zoeken en kopieren

[Djoties]

Beste mensen,

Wie kan mij helpen met de volgende macro???
Ik heb een gigantische data (zie blad data). Vervolgens krijg ik van een klant wat nummers/codes (zie blad codes). De codes staan in kolom A.
De macro moet het volgende doen:
De codes worden door de macro gezocht in werkblad “data” en zet dus de gevonden regelnummers achter de codes in kolom B werkblad codes.Vervolgens wordt uit kolom B de unieke regelsnummers uitgehaald en de regels gekopierd naar werkblad “kopierblad”.
Wie o wie kan mij hiermee helpen.

Alvast bedankt

 

[Warme bakkertje]

Het zal waarschijnlijk aan mij liggen, maar ik krijg er kop noch staart aan.

Mvg

Rudi

 

[Superzeeuw]

Rudi,

Wat Djoties bedoelt is het volgende:

Sheet Data bevat alle data.
Sheet Code bevat aangeleverde codes van een klant

Wat hij wil is de aangeleverde codes doorlopen in de sheet Data en de bijbehorende regelnummers in kolom B van tabblad Code plaatsen achter de juiste code.
Wanneer klaar, wil hij van alle gevonden regels er maar 1 gekopieerd hebben naar het tabblad Kopieer. Komt "regel 3" 6x voor dan wil hij "regel 3" maar 1x zien op het tabblad kopieer.

Ik moest het ook zes keer lezen.

Grtz.

 

[Marcel79]

Met heel veel dank aan Superzeeuw voor de vertaling:
(ik denk overigens dat dit eigenlijk in het VBA-gedeelte van het forum hoort, maar kan ik dat fixen?)

Sub RegelNummersOpzoeken()

Dim i As Long
Dim rTable As Range
Dim rFound As Range

Set rTable = ThisWorkbook.Worksheets("data").Range("A5:J15")
            'verander dit in de werkelijke grootte van je tabel
          
For i = 1 To ThisWorkbook.Worksheets("codes").Range("A65536") _
    .End(xlUp).Row

    Set rFound = rTable.Find(What:=ThisWorkbook.Worksheets("codes") _
        .Range("A" & i).Value, after:=rTable.Cells(1, 1), Lookat:=xlWhole)
    If Not rFound Is Nothing Then _
        ThisWorkbook.Worksheets("codes").Range("B" & i).Value = _
            rFound.Row
Next i

ThisWorkbook.Worksheets("Codes").Range("B1", _
    ThisWorkbook.Worksheets("Codes").Range("B65536").End(xlUp)) _
    .AdvancedFilter action:=xlFilterCopy, _
    copytorange:=ThisWorkbook.Worksheets("Kopierblad").Range("A1"), _
    unique:=True

If Application.WorksheetFunction.CountIf(ThisWorkbook _
    .Worksheets("Kopierblad").Cells, ThisWorkbook _
    .Worksheets("Kopierblad").Range("A1")) > 1 Then _
    ThisWorkbook.Worksheets("Kopierblad").Range("A1").Clear
End Sub

Kopieren van unieke regelnummers gebeurt m.b.v. AdvancedFilter. Omdat - om redenen mij onbekend - de éérste waarde toch vaak dubbel gekopieerd wordt, is daar een controle opgezet en wordt die zonodig verwijderd.

 

[Djoties]

Super!!!!!!!!

Beste mensen,

Heel erg bedankt voor jullie inzet.
En sorry voor mijn onduidelijke opzet.

Het ziet er super uit!!!
Ik heb alleen nog 1 vraag.

Is het mogelijk op het werkblad " kopierblad" de unieke regels vanuit de data te kopieren en plakken i.p.v de unieke regels nummers te vermelden?


Maar nogmaals, tot zover heeel erg Dank!

Djoties

 

[Marcel79]

aan het einde van de procedure (vóór 'End Sub') invoegen:

For i = 1 To ThisWorkbook.Worksheets("kopierblad").Range("A65536") _
    .End(xlUp).Row
    'voor elke rij op "Kopierblad"
    If ThisWorkbook.Worksheets("kopierblad").Range("A" & i) <> 0 Then _
        ThisWorkbook.Worksheets("data").Range("A" & ThisWorkbook.Worksheets _
        ("kopierblad").Range("A" & i).Value).EntireRow.Copy _
        Destination:=ThisWorkbook.Worksheets("kopierblad").Range("A" & i)
    'als er een waarde in kolom A staat, kopieer de rij op "Data" _
    die genoemd wordt
Next i

Dit vervangt elke waarde in het "Kopierblad" door de regel uit "Data" die er mee correspondeert.

werkt als volgt:
De eerste regel (For i = 1 to ...) zet een teller in gang, van 1 tot het regelnummer van de laatste regel met een waarde op "Kopierblad"

If ThisWorkbook.Worksheets("kopierblad").Range("A" & i) <> 0 Then

Als de waarde in kolom A ongelijk aan nul is, ofwel er staat iets op die regel, dan...

ThisWorkbook.Worksheets("data").Range("A" & [B]ThisWorkbook.Worksheets _
        ("kopierblad").Range("A" & i).Value[/B]).EntireRow.Copy

Het vetgedrukte deel vertelt welke waarde er in kolom A van kopieerblad staat, bijvoorbeeld '5'. De rest van de code zorgt ervoor dat van A5 op het werkblad "Data" vervolgens de volledige rij (EntireRow) gekopieerd wordt....

Destination:=ThisWorkbook.Worksheets("kopierblad").Range("A" & i)

en plak de gekopieerde regel op het werkblad "Kopierblad", op regel i (waarbij i de teller is waarmee we de regels één voor een doorlopen).

Met andere woorden, hiermee worden de regelnummers vervangen door een kopie van de bedoelde rijen.

Succes ermee, Marcel

 

[Djoties]

Marcel,

Super!!!!!!!!!!

Mijn dank is groot.

Groetjes,

Djoties

 

[Wigi]

Zet de vraag dan nog eventjes op opgelost aub :thumb:

 

[Warme bakkertje]

@Marcel
Voor de leesbaarheid van je code kan je onderstaande opnemen aan het begin van je macro en dan overal in je code ThisWorkBook vervangen door wkb

Dim wkb As Workbook
Set wkb = ThisWorkbook

Mvg

Rudi

 

[Djoties]

Toch nog een vraagje?

Kun je ook de cellen laten inkleuren (geel) op werkblad "kopierblad" van de gezochte waarden die op werkblad "codes" staan?

Alvast bedankt

 

[Marcel79]

Het worden wellicht wel wat veel loops, maar goed:

For i = 1 To ThisWorkbook.Worksheets("Codes").Range("A65536") _
    .End(xlUp).Row
    'voor elke rij op "Codes"
    Set rFound = ThisWorkbook.Worksheets("Kopierblad").Cells _
        .Find(What:=ThisWorkbook.Worksheets("codes") _
        .Range("A" & i).Value, _
        after:=ThisWorkbook.Worksheets("Kopierblad").Cells(1, 1), _
        Lookat:=xlWhole)
        'zoek de waarde op werkblad "Codes"
    If Not rFound Is Nothing Then rFound.Interior.ColorIndex = 6
        'en kleur 'm geel
Next i

Succes, Marcel

 

[Djoties]

Marcel, dat is Super!!!!

Ik zal je niet meer lastig vallen.

Heel erg bedankt
Een de groetjes
Djoties

 

[Marcel79]

Graag gedaan, als ik het lastig had gevonden had ik het topic wel genegeerd ;-)