Doppelte Eintraege-2.Versuch

Sub doppelte_Datensaetze() Sheets(1).Select znr = 1 znr1 = znr + 1 Neustart: Do Cells(znr, 1).Select If ActiveCell <> "" Then 'If ActiveCell = artikelnr Then 'znr = znr + 1 'GoTo Neustart 'End If Automarke = Cells(znr, 1) Modell = Cells(znr, 2) znr1 = znr + 1 Cells(znr1, 1).Select Do aktion = "" If ActiveCell = Automarke Then Automarke = Cells(znr1, 1) Modell = Cells(znr1, 2) Rows(znr1).Delete Sheets(2).Select Do suchnr = suchnr + 1 Cells(suchnr, 1).Activate Loop Until ActiveCell = "" Cells(suchnr, 1) = Automarke Cells(suchnr, 2) = Modell aktion = "nicht erhöhen" End If Sheets(1).Select If aktion = "" Then znr1 = znr1 + 1 Cells(znr1, 1).Select Loop Until ActiveCell = "" End If znr = znr + 1 Loop Until Cells(znr, 1) = "" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub doppelte_Datensaetze() Dim Reihe As Integer Dim i As Integer Reihe = 1 i = 1 Do While Sheets(1).Cells(Reihe, 1) <> "" If Sheets(1).Cells(Reihe, 1) = Sheets(1).Cells(Reihe + 1, 1) And Sheets(1).Cells(Reihe, 2) = Sheets(1).Cells(Reihe + 1, 2) Then Sheets(2).Cells(i, 1) = Sheets(1).Cells(Reihe, 1) Sheets(2).Cells(i, 2) = Sheets(1).Cells(Reihe, 2) Sheets(1).Cells(Reihe, 1).Interior.ColorIndex = 3 Sheets(1).Cells(Reihe, 2).Interior.ColorIndex = 3 i = i + 1 End If Reihe = Reihe + 1 Loop End Sub

Hallo Micha,
genau dort stehen sie auch.
Weiteres problem:
Mein Datensatz ist relativ gross (ueber 1000 Zeilen). Das wuerde beim momentanen Code zu ueber einer Million Rechenschritte fuehren.
Ich koennte die Liste ja vorher sortieren, so dass immer nur die aktive Zeile mit der naechsten verglichen wird (wenn nicht gleich, dann die naechste mit der uebernaechsten, usw.-wenn gleich, dann die aktive mit der uebernaechsten usw.).
so wird das alles auf 1500 Schritte reduziert!!!
Mein bisheriger Code der auch gut funktioniert ist:
Public


Sub Liste_doppelte()
Dim wert1(100)
Dim wert2(200)
Dim zeilen
Dim c As Variant
zeilen = 17 'Anzahl der Zeilen die geprüft werden sollen
zaehler = 0
'Werte in Variablen einlesen
For i = 1 To zeilen
wert1(i) = Cells(i, 1)
wert2(i) = Cells(i, 1)
Next i
'Schleife um die Variable wert1(i) mit wert2(i) zu vergleichen
For i = 1 To zeilen
zaehler = 0
'Schleife, um die Variable wert1(i) mit wert2(i) zu vergleichen
For J = 1 To zeilen
If wert1(i) = wert2(J) Then
zaehler = zaehler + 1
If zaehler > 1 Then
Sheets(2).Select
Cells(i, 1).Value = wert2(i)
'wert2(i) = ""
End If
End If
Next J
Next i
End Sub

Jedoch hat er das Problem mit den vielen rechenschritten! Ausserdem kopiert er nur den ersten Wert der ersten Spalte, ich will aber die komplette Zeile in der 2.Tabelle haben.
Kannst Du mir da helfen?
Ich werde nun ins Bett gerufen,
also ne Gute Nacht,
Timo

Sub doppelte_Datensaetze() Dim Reihe As Integer Dim i As Integer Dim x As Integer Dim y As Integer Dim ZWS(1 To 2000, 1 To 2) As String i = 1 timeranfang = Time For Reihe = 1 To 2000 ZWS(Reihe, 1) = Sheets(1).Cells(Reihe, 1) ZWS(Reihe, 2) = Sheets(1).Cells(Reihe, 2) Next Reihe For x = 1 To 2000 For y = x + 1 To 2000 If ZWS(x, 1) <> "" Then If ZWS(x, 1) = ZWS(y, 1) And ZWS(x, 2) = ZWS(y, 2) Then Sheets(1).Rows(x).Copy Sheets(2).Rows(i) Sheets(1).Rows(x).Interior.ColorIndex = 3 i = i + 1 End If End If Next y Next x End Sub

Sub doppelte_Datensaetze() Dim Reihe As Integer Dim i As Integer Dim x As Integer Dim y As Integer Dim ZWS(1 To 2000, 1 To 2) As String i = 1 timeranfang = Time For Reihe = 1 To 2000 ZWS(Reihe, 1) = Sheets(1).Cells(Reihe, 1) ZWS(Reihe, 2) = Sheets(1).Cells(Reihe, 2) Next Reihe For x = 1 To 2000 For y = x + 1 To 2000 If ZWS(x, 1) <> "" Then If ZWS(x, 1) = ZWS(y, 1) And ZWS(x, 2) = ZWS(y, 2) Then Sheets(1).Rows(x).Copy Sheets(2).Rows(i):i=i+1 Sheets(1).Rows(y).Copy Sheets(2).Rows(i):i=i+1 Sheets(1).Rows(x).Interior.ColorIndex = 3 Sheets(1).Rows(y).Interior.ColorIndex = 3 End If End If Next y Next x End Sub

Sub doppelte_DatensaetzeTimo() Dim Reihe As Integer Dim i As Integer Dim x As Integer Dim y As Integer Dim ZWS(1 To 2000, 1 To 2) As String i = 1 timeranfang = Time For Reihe = 1 To 2000 ZWS(Reihe, 1) = Sheets(1).Cells(Reihe, 1) ZWS(Reihe, 2) = Sheets(1).Cells(Reihe, 2) Next Reihe For x = 1 To 2000 For y = x + 1 To 2000 If ZWS(x, 1) <> "" Then If ZWS(x, 1) = ZWS(y, 1) And ZWS(x, 2) = ZWS(y, 2) Then Sheets(1).Rows(x).Copy Sheets(2).Rows(i) Sheets(1).Rows(x).Interior.ColorIndex = 3 Sheets(1).Rows(y).Copy Sheets(2).Rows(i) Sheets(1).Rows(y).Interior.ColorIndex = 3 i = i + 1 End If End If Next y Next x End Sub

Sub doppelte_Datensaetze() Dim Reihe As Integer Dim i As Integer Dim x As Integer Dim y As Integer Dim ZWS(1 To 2000) As String i = 1 For Reihe = 1 To 2000 ZWS(Reihe) = Sheets(1).Cells(Reihe, 1) Next Reihe For x = 1 To 2000 For y = x + 1 To 2000 If ZWS(x) <> "" Then If ZWS(x) = ZWS(y) Then Sheets(1).Rows(x).Copy Sheets(2).Rows(i): i = i + 1 Sheets(1).Rows(y).Copy Sheets(2).Rows(i): i = i + 1 Sheets(1).Rows(x).Interior.ColorIndex = 3 Sheets(1).Rows(y).Interior.ColorIndex = 3 End If End If Next y Next x End Sub

Beliebteste Forumthreads (12 Monate)

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread