Ontdubbelen, markeren en verpaatsen

Status
Niet open voor verdere reacties.
HWV

HWV

Terugkerende gebruiker
Lid geworden
19 feb 2009
Berichten
1.183
Goedendag,

Ik heb een code voor ontdubbelen in een worksheet.
Nu zou ik eigenlijk het volgende voor elkaar krijgen.
Nu markeer hij de cellen in het rood, en de optie om te verwijderen.
Ik zou graag deze optie`s laten staan en dat er een soort van kopie wordt gemaakt op een andere blad waar dan de dubbelen komen te staan.
Al flink gezocht maar krijg het maar niet gevonden.
Ik hoop dat jullie hier iets op weten

Code: 
Sub sorteertest()
Worksheets("Blad1").Range("A1").Sort _
Key1:=Worksheets("Blad1").Range("A1")
Set currentCell = Worksheets("Blad1").Range("A1")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If nextCell.Value = currentCell.Value Then
' currentCell.EntireRow.Delete
currentCell.EntireRow.Interior.ColorIndex = 3
End If
Set currentCell = nextCell
Loop
End Sub

HWV
 
Volgens mij moet dit het dan zijn
Code: 
Sub sorteertest()
Worksheets(1).Range("A1").Sort Key1:=Worksheets(1).Range("A1")
Set currentcell = Worksheets(1).Range("A1")
i = 1
Do While Not IsEmpty(currentcell)
Set nextCell = currentcell.Offset(1, 0)
If nextCell.Value = currentcell.Value Then
    currentcell.EntireRow.Interior.ColorIndex = 3
    currentcell.EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    i = i + 1
    Set currentcell = nextCell
    currentcell.Offset(-1, 0).EntireRow.Delete
Else
    Set currentcell = nextCell
End If

Loop
End Sub
 
Helaas werkt niet

Helaas Henk , het werkt niet
Ik krijg al een foutmelding op de eerste regel.
Heb zitten kijken waar de fout zou liggen maar niet gevonden.
Deze code zou dus de dubbelen uit het werkblad halen en transporteren naar een ander blad. Ben benieuwd als hij het doet.

Groet HWV
 
worden de regels die verwijderd moeten worden nog wel rood gemaakt?
ik heb namelijk niets aan je code gewijzigd, alleen maar een paar regels toegevoegd, en volgens mij moet het gewoon werken.

Anders moet je gewoon even een voorbeeld plaatsen, om aan te geven wat er precies fout gaat.
 
Bij het eerst gevonden dubbele gaat het fout

Hé Henk,

Als hij de eerste dubbele vind dat gaat het verkeerd. Hij maak de eerste wel rood maar dan gaat het fout.
Hij geef een fout in regel ;
Code: 
    Worksheets(2).Rows(i).Insert shift:=xlDown

Groet HWV
 

Bijlagen

  • Voorbeeld-2.xls
    28,5 KB · Weergaven: 66
Laatst bewerkt:
dat komt omdat je maar 1 worksheet hebt. als je even een tabblad toevoegd werkt het wel.
maar doordat je complete rijen knipt en plakt worden de opmerkingen die je bovenaan in het midden hebt staan ook meegenomen naar het tweede tabblad.
 
Geweldig bedankt

Fijn dat er mensen zijn die met je meedenken.
Het is inderdaad zo even een blad toevoegen en hij doet het.

bedankt

HWV
 
toch nog even terug komen....

Nu gaan de rode cellen ook mee.
Is het mogelijk dat hij net de andere pak en de rode cellen laat staan, of ook rood maakt.
Dan kan ik de dubbele nog controleren.Met een paar regels is het te doen maar al je duizend moet controleren gaat het wat moeilijker.

HWV
 
dan zou je deze code moeten proberen, volgens mij gaat deze ook sneller dan de vorige. De vorige code begon na het verwijderen van een rij weer vanaf rij 1 te controleren, deze code gaat verder vanaf het punt waar een rij is verwijderd.

Als de waarde in cel A2 gelijk is aan de waarde van cel A1, dan wordt rij 1 rood gemaakt en rij 2 verplaatst naar het tweede tabblad.

Code: 
Sub sorteertest()
Worksheets(1).Range("A1").Sort Key1:=Worksheets(1).Range("A1")
Set currentcell = Worksheets(1).Range("A1")
i = 1
Do While Not IsEmpty(currentcell)
If currentcell.Offset(1, 0).Value = currentcell.Value Then
    currentcell.EntireRow.Interior.ColorIndex = 3
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
Else
    Set currentcell = currentcell.Offset(1, 0)
End If
Loop
End Sub
 
Sorteertest

Bedankt voor je input geweldig.
Hij haalt de dubbelen er uit en verplaatst deze naar een ander veld.
Hij ziet verschil tussen hoofdletter en kleine letter .

Ik heb nog 2 vraagjes.

Als er in bv cel a1 staat "piet jansen" en cel b1 "Piet Jansen"
Het verschil is de hoofdletter.
Zou die ook mee kunnen in de soorteer test en dan in het andere blad groen acceren.

Als er in bv cel a1 staat "piet jansen" en cel b1 "Piet Jansen thuis"
Het verschil is het extra woord in de regel in dit geval "thuis".
Zou die ook mee kunnen in de soorteer test en dan in het andere blad bv geel acceren

Alvast bedankt voor de input en voor het meedenken.

HWV
 
Dat kan. Om de hoofdletters te omzeilen zou je bijv. het volgende kunnen gebruiken:
Code: 
ElseIf uCase(currentcell.Offset(1, 0).Value) = uCase(currentcell.Value) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    Worksheets(2).Rows(i).Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1

Je plaatst dit dan in het If-statement vóór de regel die begint met "Else". Dit ElseIf statement doet hetzelfde als het If statement, maar zet de inhoud van de te vergelijken cellen eerst om in hoofdletters.

Je tweede punt kan met een andere ElseIf worden opgelost, je moet dan alleen gebruik maken van "Instr() <> 0".
Als voorbeeld geef je daar echter "Piet Jansen" en "Piet Jansen thuis", zodra iemand echter "thuis Piet Jansen" heeft ingevuld gaat het verkeerd, omdat de regel dan op een heel andere plaats staat. In dat geval moet je dus een code hebben die door de hele kolom zoekt (ipv alleen maar een vergelijk met de onderliggende cel).
 
Beste,

Bedankt voor de reactie op mijn vraag.
Ik heb de code aangepast :
Code: 
Sub sorteertest1()
Worksheets(1).Range("A1").Sort Key1:=Worksheets(1).Range("A1")
Set currentcell = Worksheets(1).Range("A1")
i = 1
Do While Not IsEmpty(currentcell)
If currentcell.Offset(1, 0).Value = currentcell.Value Then
    currentcell.EntireRow.Interior.ColorIndex = 3
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
ElseIf UCase(currentcell.Offset(1, 0).Value) = UCase(currentcell.Value) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    Worksheets(2).Rows(i).Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
Else
    Set currentcell = currentcell.Offset(1, 0)
End If
Loop
End Sub
Het werkt als een trein met deze code.
Enkel je tweede punt begrijp ik niet waar ik dit moet plaatsen:
Je tweede punt kan met een andere ElseIf worden opgelost, je moet dan alleen gebruik maken van "Instr() <> 0".
Klik om te vergroten...

Groet HWV
 
Je krijgt dan nog een ElseIf statement (die plaats je na het eerste ElseIf statement). Volgens mij moet onderstaande code werken:

Code: 
ElseIf InStr(1, currentcell.Offset(1, 0).Value, currentcell.Value, vbTextCompare) <> 0 And Not IsEmpty(currentcell.Offset(1, 0)) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
 
Perfect

Beste,

het werkt perfect hier de code zoals hij is geworden:
Code: 
Sub sorteertest1()
Worksheets(1).Range("A1").Sort Key1:=Worksheets(1).Range("A1")
Set currentcell = Worksheets(1).Range("A1")
i = 1
Do While Not IsEmpty(currentcell)
If currentcell.Offset(1, 0).Value = currentcell.Value Then
    currentcell.EntireRow.Interior.ColorIndex = 3
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
ElseIf UCase(currentcell.Offset(1, 0).Value) = UCase(currentcell.Value) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    Worksheets(2).Rows(i).Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
ElseIf InStr(1, currentcell.Offset(1, 0).Value, currentcell.Value, vbTextCompare) <> 0 And Not IsEmpty(currentcell.Offset(1, 0)) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
ElseIf UCase(currentcell.Offset(1, 0).Value) = UCase(currentcell.Value) Then
    currentcell.EntireRow.Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Cut
    Worksheets(2).Rows(i).Insert shift:=xlDown
    Worksheets(2).Rows(i).Interior.ColorIndex = 4
    currentcell.Offset(1, 0).EntireRow.Delete
    i = i + 1
Else
    Set currentcell = currentcell.Offset(1, 0)
End If
Loop
End Sub

Bedankt voor een ieder die hier aan mee heeft gewerkt.

Groet HWV
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan