vba code om unieke getallen te filteren in een bereik

[mtb]

Hoi,

Naar aanleiding van mijn vorige vraag

http://www.helpmij.nl/forum/showthread.php?t=333943

die bye the way perfect is opgelost, loop ik tegen de volgende beperking aan. In het zoek bereik komen nu ook lege cellen en 0 waarde voor, de bedoeling is dat deze niet meegenomen worden. Naar mijn bescheiden mening is dit alleen op te lossen met een VBA code, wellicht dat iemand mij hier mee zou kunnen helpen, want ik kom hier echt niet uit.

als voorbeeld een bestand bijgevoegd

alvast bedankt.

 

[mtb]

Hoi,

Iemand al enig idee hoe dit opgelost moet/kan worden. Ben gister en vanochtend de hele tijd bezig geweest om de structuur achter een code uit te pluizen maar kom er echt niet uit.

 

[Gert Bouwmeeste]

Is dit iets?

Sub UniekeWaarden()

    ' Selecteer het gebied waar de te filteren waarden staan
    ' Let op, boven het datagebied moet een veldnaam staan die gelijk moet zijn
    ' aan de veldnaam voor de criteria (cel G1)
    
    Range("G5:G48").Select
    Range(Selection, Selection.End(xlDown)).Select
    
    ' Voor de filter uit en kopieer de unieke waardes naar cel B5
    Range("G4:G21").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "G1:G2"), CopyToRange:=Range("B5"), Unique:=True
    
    ' Selecteer de gekopieerde unieke waardes
    Range("B5:B65000").Select
    
    ' Vervang de nul met Zoeken & Vervangen door "" (niets)
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
    'Sorteer de gekopieerde en van "0" ontdane reeks om de lege regels eruit te krijgen
    Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
End Sub

Zie ook bijgevoegd bestand. Let op de vereiste kopregels!

 

[mtb]

Gert,

Bedankt voor je reactie, ga er vanavond mee aan de gang om het te testen
Je hoort morgen van me

thanks a lot

 

[mtb]

Gert,

De code bijna helemaal goed, ik heb hem omgebouwd naar mijn bestand (ook dat is redelijk gelukt) , ik krijg nu alleen bij het kopieren van de unieke records steeds 1 lege regel onder de veldnaam.

wellicht heeft het te maken met de volgende stukken code, kun jij mij vertellen wat die doen???

[COLOR="Red"]Range(Selection, Selection.End(xlDown)).Select[/COLOR]

bij onderstaande stukje code vraag ik mij af waarom er 2 cellen (in het rood) gedeclareerd worden, cel G1 snap ik want dat is de veldnaam, maar waarom ook G2.

Range("G4:G21").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "[COLOR="Red"]G1:G2[/COLOR]"), CopyToRange:=Range("B5"), Unique:=True

bij onderstaande code word toch alleen geselecteerd van boven naar beneden? bij jouw opmerking bij de code (in het groen) schrijf jij dat hier de lege regels verwijderd worden, welk stukje zorgt ervoor, want mijn lege regel onder de veldnaam blijft nl.staan

Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

alvast bedankt voor je moeite:thumb::thumb::thumb:

 

[GiMe]

Hierbij een voorbeeldje zonder VBA.

 

[Gert Bouwmeeste]

Bij mij ontstaat er geen lege regel net onder de veldnaam. Ik herken het wel, heeft iets met sorteren te maken. Onderstaand antwoord op je vragen plus een stukje aanvulling van de macro die jouw probleem oplost.

[COLOR="Red"]Range(Selection, Selection.End(xlDown)).Select[/COLOR]

Deze regel, samen met de regel daarboven, selecteert je brontabel t/m de laatste regel. Je zou beide regels ook kunnen vervangen door

Range("G5:G65000").Select

bij onderstaande stukje code vraag ik mij af waarom er 2 cellen (in het rood) gedeclareerd worden, cel G1 snap ik want dat is de veldnaam, maar waarom ook G2.

G2 is normaal gesproken het veld waar het selectiecriterium in komt te staan. Er staat nu niets in omdat alles geselecteerd moet worden, maar dan met unieke waardes. G2 is verplicht.

Range("G4:G21").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "[COLOR="Red"]G1:G2[/COLOR]"), CopyToRange:=Range("B5"), Unique:=True

bij onderstaande code word toch alleen geselecteerd van boven naar beneden? bij jouw opmerking bij de code (in het groen) schrijf jij dat hier de lege regels verwijderd worden, welk stukje zorgt ervoor, want mijn lege regel onder de veldnaam blijft nl.staan

Er wordt niet geselecteerd maar gesorteerd van boven naar beneden. De lege regel blijft bij mij niet staan, maar ik herken dat wel.

Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Voeg deze code toe aan het einde van de macro en het is opgelost:

' Selecteer vanaf regel 7 t/m einde en kopieer deze
    Range("B7:B65000").Select: Selection.Copy
    ' Ga naar regel 6 en plak
    Range("B6").Select
    ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
        IconFileName:=False
    ' kopieer de opmaak van regel 7 naar regel 6
    Range("B7").Select
    Selection.Copy
    Range("B6").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

 

[Hoornvan]

Hallo mtb,

Bij mij werkt de aangepaste Macro niet correct, licht misschien aan mijn Office 2007.
Probeer deze eens uit (bijlage)

Als ik extra artikel ID in vulde dan pakte hij die wel maar plaatste ze niet in kolom B.
Nu doet hij dit wel en hopelijk bij jou ook.

Suc6,
Wim

 

[mtb]

Heren

Allen hartstikke bedankt voor jullie aangedragen oplossingen, probleem is opgelost. Geweldig zo'n forum waar je met je problemen terecht kunt als je er zelf niet meer uit komt.

werkelijk top