• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Ontdubbelen op Kolom A en C met voorwaarde

  • Onderwerp starter Onderwerp starter HWV
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
HWV

HWV

Terugkerende gebruiker
Lid geworden
19 feb 2009
Berichten
1.213
Beste,

ik gerbuik een VBA code in een deel van mijn code om te ontdubbelen in kolom A.

Is het mogelijk om te ontdubbelen op 2 kolommen A en C
In A staat het artikel nummer en in C het bedrag.
Als in A dubbelen staat ontdubbelen, maar als in C die niet dubbel zijn dan de regel laten staan.
Een vervolg stap hierin is dat als in kolom A dubbelen staan dat er gekeken wordt naar kolom C naar het hoogste bedrag, en dat er dan in kolom D er een * komt te staan naast het hoogste bedrag in kolom C.

Code: 
myrow = "A"

Columns(myrow & ":" & myrow).Select
AllRows = Range(myrow & "65536").End(xlUp).Row
i = 1
For i = 1 To AllRows
Range(myrow & i).Select
TrimValue = Range(myrow & i).Value
Range(myrow & i).Value = Trim(TrimValue)
Next

Ik hoop dat het mogelijk is, en in VBA

groet
HWV
 

Bijlagen

Laatst bewerkt:
Code gelukt, maar wel lang

Beste,

Ik heb het voor elkaar gekregen om mijn doel te bereiken.
( dit is wel de code uit mijn oorspronkelijke bestand )

Ik sorteer eerst vanaf regel 24 op kolom A en C
Dan kijk ik naar dubbelen in kolom A en kolom C, zitten daar gelijken in zowel kolom A en kolom C dan verwijderen van de regel.

In kolom A kijken voor dubbelen , dan kijken wat het grootste bedrag is in kolom C, is het hoogste bedrag gevonden dan een * bij het hoogste bedrag in kolom E.

Dan in kolom A kijken voor dubbelen , dan kijken wat het KLEINSTE bedrag is in kolom C, is het KLEINSTE bedrag gevonden dan een * bij het hoogste bedrag in kolom E. Range("E" & i - 1) = "*"

Code: 
Sub Haal_dubbele_weg()

    Rows("24:24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("A24"), Order1:=xlAscending, Key2:=Range("C24" _
        ), Order2:=xlDescending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal     

laatste = Range("C65000").End(xlUp).Row
For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) = Range("C" & i - 1) And Range("C" & i) = Range("C" & i - 1) Then
Range("F" & i).EntireRow.Delete
End If
Next i

For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) > Range("C" & i - 1) And Range("C" & i) > Range("C" & i - 1) Then
Range("E" & i) = "*"
End If
Next i

For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) < Range("C" & i - 1) And Range("C" & i) < Range("C" & i - 1) Then
Range("E" & i - 1) = "*"
End If
Next i

End Sub

Aanvullingen of verbeteringen zijn altijd welkom

Groet HWV
 
Het is een goed idee om te sorteren maar volgens mij is het dan een kwestie van het vergelijken van de kolommen.
Mijn code is dan ook iets korter.

Code: 
Sub Haal_dubbele_weg()
Dim lRij As Long
    Range("A24:C1000").Sort Key1:=Range("A24"), Order1:=xlAscending, Key2:=Range("C24" _
        ), Order2:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal

    lRij = 24
    While Range("A" & lRij).Value <> ""
        If Range("A" & lRij).Value = Range("A" & lRij + 1).Value And Range("C" & lRij).Value = Range("C" & lRij + 1).Value Then
            Range("A" & lRij).EntireRow.Delete
        End If
        lRij = lRij + 1
    Wend
    
End Sub

Met vriendelijke groet,


Roncancio
 
Dat is deel één van mijn code

Roncancio,

Bedankt voor je reactie.
Het doet inderdaad vergelijk wat overeenkomt met het stukje uit mijn code:
Code: 
    Rows("24:24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("A24"), Order1:=xlAscending, Key2:=Range("C24" _
        ), Order2:=xlDescending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal     

laatste = Range("C65000").End(xlUp).Row
For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) = Range("C" & i - 1) And Range("C" & i) = Range("C" & i - 1) Then
Range("F" & i).EntireRow.Delete
End If
Next i

Deel twee van mijn code zorg er voor dat er een * komt te staan bij het hoogste bedrag.
Code: 
For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) > Range("C" & i - 1) And Range("C" & i) > Range("C" & i - 1) Then
Range("E" & i) = "*"
End If
Next i

For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) < Range("C" & i - 1) And Range("C" & i) < Range("C" & i - 1) Then
Range("E" & i - 1) = "*"
End If
Next i

Ik moest het in twee keer doen want een kortere code kreeg ik niet voor elkaar.

Mischien kan je me helpen met het volgende.
Ik moet de regel onder de * verwijderen (als extra optie in mijn formulier.
Hoe kan ik dat het beste aanpakken)

Groet HWV
 
Met onderstaande code blijft er van elk artikelnr alleen de hoogste waarde over.
De overige waardes van elk artikelnr wordt verwijderd.
Code: 
Sub Haal_dubbele_weg()
Dim lRij As Long
    Range("A24:C1000").Sort Key1:=Range("A24"), Order1:=xlAscending, Key2:=Range("C24" _
        ), Order2:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal

    lRij = 24
    While Range("A" & lRij).Value <> ""
        If Range("A" & lRij).Value = Range("A" & lRij + 1).Value And Range("C" & lRij).Value >= Range("C" & lRij + 1).Value Then
            Range("A" & lRij + 1).EntireRow.Delete
        End If
        lRij = lRij + 1
    Wend
    
End Sub

Met vriendelijke groet,


Roncancio
 
Thanks

Roncancio,

Ik ga het uit proberen.
Bedankt voor je inbreng.

groet HWV
 
onderstaande filtert de rij waar de 1e maximale waarde van een product staat af.
Dan zou ht niet moeilijk meer zijn om de rest te wissen, selectie omkeren en wissen.
Code: 
Sub ZoekGrootste()
  Dim LastRij As Long, c As Range
  ActiveSheet.AutoFilterMode = False                       'ev. filter uitzetten
  LastRij = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row  'laatste niet-lege A-cel
  Set c = ActiveSheet.Range("A24:A" & LastRij)             'gans het bereik in de A-kolom
  c.Offset(, 3).FormulaR1C1 = "=IF(MAX((" & c.Address(, , xlR1C1) & "=RC1)*(" & c.Offset(, 2).Address(, , xlR1C1) & "))<>RC3,"""",IF(SUMPRODUCT((" & c.Address(, , xlR1C1) & "=RC1)*(" & c.Offset(, 2).Address(, , xlR1C1) & "=RC3))=1,""x"",""""))"  'zet een "*" bij de 1e maximale waarden van een bepaald produkt
  c.Offset(, 3).Range("A1") = "maximum"
  c.Offset(, 3).AutoFilter 1, "x"                          'filter al die "*"
End Sub
 
MMM werkt niet

Beste,

ik heb het geprobeerd op mijn testbestand van topic 1 maar krijg achter elke regel een X te staan.
Hij laat het niet zien bij het hoogste getal.

Controleer in kolom A op dubbelen, van die dubbelen dan de hoogste waarde uit kolom D en dan in E een X bij het hoogste getal van de twee gelijken.

Groet HWV
 
hallo HWV

Deel twee van mijn code zorg er voor dat er een * komt te staan bij het hoogste bedrag.
Code:
For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) > Range("C" & i - 1) And Range("C" & i) > Range("C" & i - 1) Then
Range("E" & i) = "*"
End If
Next i

For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) < Range("C" & i - 1) And Range("C" & i) < Range("C" & i - 1) Then
Range("E" & i - 1) = "*"
End If
Next i
Klik om te vergroten...

werkt dit ook als er meer dan 2 gelijken in kolom A staan?

groet sylvester
 
Als er meerdere dubbelen in zitten heb ik die er al uit gehaald met de volgende code (zie ook topic 1)

Code: 
laatste = Range("C65000").End(xlUp).Row
For i = laatste To 24 Step -1
If Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1) And Range("C" & i) = Range("C" & i - 1) And Range("C" & i) = Range("C" & i - 1) Then
Range("F" & i).EntireRow.Delete
End If
Next i

Als er dubbelen in zitten dan is het altijd met gelijk aan Kolom A en kolom C, vandaar dat ik deze code kan gebruiken.

Helaas kom ik er net achter dat de vlieger niet helemaal op gaat, de code hierboven.
Omdat er niet altijd een prijsverhoging is , maar ook een prijsverlaging.
Nu heb ik geen kolom om te trikkeren welke regel ik moet nemen.
ben nu aan het kijken of ik in de export uit ons systeem ook een startdatum van de nieuwe afspraak kan halen , want dat is dan mijn trikkerveld

Groet HWV
 
je hebt veel dubbele voorwaarden in je code bv:
Code: 
Range("A" & i) = Range("A" & i - 1) And Range("A" & i) = Range("A" & i - 1)
is hetzelfde als
Code: 
Range("A" & i) = Range("A" & i - 1)

groet sylvester
 
Laatst bewerkt:
je schrijft:
Ik sorteer eerst vanaf regel 24 op kolom A en C
Dan kijk ik naar dubbelen in kolom A en kolom C, zitten daar gelijken in zowel kolom A en kolom C dan verwijderen van de regel.

In kolom A kijken voor dubbelen , dan kijken wat het grootste bedrag is in kolom C, is het hoogste bedrag gevonden dan een * bij het hoogste bedrag in kolom E.

Dan in kolom A kijken voor dubbelen , dan kijken wat het KLEINSTE bedrag is in kolom C, is het KLEINSTE bedrag gevonden dan een * bij het hoogste bedrag in kolom E. Range("E" & i - 1) = "*"
Klik om te vergroten...

omdat je gesorteerd hebt op kolom A en kolom C staat bij gelijke A in kolom C het grootste bedrag altijd bovenaan.
dus als alle dubbele rijen verwijderd zijn hoef je alleen nog te kijken of er nog dubbele voorkomen in kolom A en dan een * bij de eerste van de dubbelen te zetten.
zo iets blijft er dan over:
Code: 
Sub Haal_dubbele_weg()
    Columns("E").ClearContents
    Range(Rows(24), Rows(24).End(xlDown)).Sort Key1:=Range("A24"), Order1:=xlAscending, Key2:=Range("C24" _
        ), Order2:=xlDescending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
    laatste = Range("C65000").End(xlUp).Row
    For i = laatste To 24 Step -1                              'dubbele verwijderen
        If Range("A" & i) = Range("A" & i - 1) And Range("C" & i) = Range("C" & i - 1) Then
            Range("F" & i).EntireRow.Delete
        End If
    Next i
    laatste = Range("C65000").End(xlUp).Row      'er zijn misschien rijen verwijderd dus opnieuw laatste bepalen
    For i = laatste To 24 Step -1
        If Range("A" & i) = Range("A" & i - 1) Then
            Range("E" & i - 1) = "hoog"
        End If
    Next i
End Sub

als je straks met prijs wijzigings datums werkt blijft de code bijna het zelfde

groet sylvester
 
met een matrixformule in D zoek je de grootste en 1e voor een bepaald produkt

en eigenlijk is het met een draaitabel nog eenvoudiger
 

Bijlagen

Laatst bewerkt:
Beste sylvester-ponte en cow18,

Bedankt voor jullie inbreng.

Ik ga het allemaal bekijken en doortesten, ik moet wel in mijn achterhoofd houden dat het nog kan wijzigen als ik er een datum kolom bij gaat krijgen.
Maar hier zie je nu ook al gelijk dat er meer wegen zijn naar je doel.

- Matrixformule
- Draaitabel
- VBA

Voor mij gaat mijn voorkeur naar VBA, elke nacht krijg ik nieuwe data via een export uit ons systeem.
Met VBA pak ik die op en bewerk deze dan tot een brief.
Maar sluit niet uit dat een draaitabel ook een optie is.


Bedankt tot zover voor de hulp.:thumb:

Groet HWV
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan