Supportnet / Forum / Tabellenkalkulation
2 Bedingungen lösen als VBA
Frage
Hallo zusammen,
hier mal wieder ein kleines Excel Problem für nighty und co:-)
Ich hätte gerne ein Makro welches 2 Bedingungen lösen kann.
In Spalte A steht eine Artikelnummer in Spalte B eine Artikelbeteichung.In Spalte C das anlegedatum vom Artikel.
Auf grund einer grossen Datenmenge kann es vorkommen, dass eine Artikelnummer doppelt oder sogar mehrfach angelegt worden ist aber mit verschiedenen Datumsangaben.
Ich hätte nun gerne, dass die mehrfach vorkomenden Artikelnummern selektiert werden und durch eine nochmalige Bestätigung, die mit älterem Datum dann gelöscht werden.
ZB Artikel Nummer 123 Datum 1.1.04.
Artikel Nummer 123 Datum 31.10.03
Ich freue mich auf Eure Lösungsvorschläge.
Vielen Dank im voraus.
Schönen Abend wünscht
TJ
Antwort 1 von Blindfisch
Hört sich kompliziert an*g*
gutes nächtle
gutes nächtle
Antwort 2 von TJ
Blindfisch danke für die Wortmeldung hat mir wirklich weitergeholfen.*grrr*
hmmmmm ansonsten keine Wortmeldung!!!
Wünsche allen ein schönes WE.
TJ
hmmmmm ansonsten keine Wortmeldung!!!
Wünsche allen ein schönes WE.
TJ
Antwort 3 von nighty
hi tj :)
hier schon mal ein makro was spalte a(artikelnummer) und spalte a(artikelnummer) vergleicht,ist a(artikelnummer) und a(artikelnummer) identich und eines von spalte b (datum) kleiner ,wird die zeile geloescht,es wird weitergesucht u.s.w.
mit der abfrage nach ja nein ob geloescht werden soll hab ich noch keine idee :(,weil es koennen ja mehrere doppelte auftauchen,man weiss ja nie wieviele kommen werden.
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 4, 2) & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 4, 2) & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
hier schon mal ein makro was spalte a(artikelnummer) und spalte a(artikelnummer) vergleicht,ist a(artikelnummer) und a(artikelnummer) identich und eines von spalte b (datum) kleiner ,wird die zeile geloescht,es wird weitergesucht u.s.w.
mit der abfrage nach ja nein ob geloescht werden soll hab ich noch keine idee :(,weil es koennen ja mehrere doppelte auftauchen,man weiss ja nie wieviele kommen werden.
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 4, 2) & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 4, 2) & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
Antwort 4 von nighty
hi tj
ich vergass noch :)
die doppelten beziehen sich nur auf tage und monate(vergleich),ich dacht reicht so :)
1) artikelnummer 12 datum 12.01.02
2) artikelnummer 12 datum 13.02.01
sollten daten kommen die mindestens ein jahr groesser oder kleiner sind ,wuerde jetzt 1) geloescht werden obwohl es neuer ist.
grrr ich aendere es
gruss nighty
ich vergass noch :)
die doppelten beziehen sich nur auf tage und monate(vergleich),ich dacht reicht so :)
1) artikelnummer 12 datum 12.01.02
2) artikelnummer 12 datum 13.02.01
sollten daten kommen die mindestens ein jahr groesser oder kleiner sind ,wuerde jetzt 1) geloescht werden obwohl es neuer ist.
grrr ich aendere es
gruss nighty
Antwort 5 von nighty
hi tj
korrigiert :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2) & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2) & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
korrigiert :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2) & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2) & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
Antwort 6 von nighty
hi tj :)
und wie immer fluechtigkeitsfehler :(
hier jetzt besser :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
und wie immer fluechtigkeitsfehler :(
hier jetzt besser :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
End If
Next t1%
Next t%
Range("A1").Select
End Sub
Antwort 7 von TJ
Hi nighty:-)
wowwwwwwwwww, das sieht ja schonmal gut aus.
Erstmal vielen Dank für Deine Mühe.
Ich denke mal wenn das hier mal richtig steht, wäre das eine tolle Sache
Primär ist es so, dass je Artikelnummer nur 1x vorhanden sein sollte.
Das Problem ist, dass mehrere User mit diesem Proggi arbeiten und sie legen einfach "drauflos an"
So eine Mittelung*Artikel bereits vorhanden* wäre auch nicht schlecht nur mal so als Idee.
Ich wünsche Dir einen schönen Sonntag.
Gruss TJ
wowwwwwwwwww, das sieht ja schonmal gut aus.
Erstmal vielen Dank für Deine Mühe.
Ich denke mal wenn das hier mal richtig steht, wäre das eine tolle Sache
Primär ist es so, dass je Artikelnummer nur 1x vorhanden sein sollte.
Das Problem ist, dass mehrere User mit diesem Proggi arbeiten und sie legen einfach "drauflos an"
So eine Mittelung*Artikel bereits vorhanden* wäre auch nicht schlecht nur mal so als Idee.
Ich wünsche Dir einen schönen Sonntag.
Gruss TJ
Antwort 8 von TJ
Hallo nighti zum 2.:-)
nu war ich doch direkt scharf dadrauf das auszuprobieren.
Das läuft ja fantastisch, ein kleiner Fehler steckt jedoch noch drin.
Nehmen wir an der Artikel 123 ist 5x angelegt.
Beim ersten klick auf den Button löscht er den Artikel genau 3x sodass noch 2x 123 stehen bleiben.
Beim nochmaligen drücken bleibt dann 1x 123 stehn und dann isset erst richtig.
Aber ansonsten..klassssseee*schulterklopp*:-)
Weiterhin schönen Sonntag wünscht
TJ
nu war ich doch direkt scharf dadrauf das auszuprobieren.
Das läuft ja fantastisch, ein kleiner Fehler steckt jedoch noch drin.
Nehmen wir an der Artikel 123 ist 5x angelegt.
Beim ersten klick auf den Button löscht er den Artikel genau 3x sodass noch 2x 123 stehen bleiben.
Beim nochmaligen drücken bleibt dann 1x 123 stehn und dann isset erst richtig.
Aber ansonsten..klassssseee*schulterklopp*:-)
Weiterhin schönen Sonntag wünscht
TJ
Antwort 9 von nighty
hi tj :)
ich glaub ich weiss woran es liegt,meld mich morgen wieder :)
gruss nighty
ich glaub ich weiss woran es liegt,meld mich morgen wieder :)
gruss nighty
Antwort 10 von TJ
Hallöle nighty,:-)
ja fein freue mich schon drauf.
Ich muss sagen, bis jetzt is das schon Klasse.
ich kann mich nur wiederholen.
Nu denkste bestimmt, nu spinnt der komplett:-)
Was auch nicht schlecht wäre, wenn ne Meldung käme diese Artikelnummern sind doppelt löschen ok.
Gutes nächtle nighty:
Gruss
TJ
ja fein freue mich schon drauf.
Ich muss sagen, bis jetzt is das schon Klasse.
ich kann mich nur wiederholen.
Nu denkste bestimmt, nu spinnt der komplett:-)
Was auch nicht schlecht wäre, wenn ne Meldung käme diese Artikelnummern sind doppelt löschen ok.
Gutes nächtle nighty:
Gruss
TJ
Antwort 11 von nighty
hi tj:)
was haelst davon :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichner " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
was haelst davon :)
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 2) & Mid$(Range("C" & t1%), 4, 2)) & Val(Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 2) & Mid$(Range("C" & t%), 4, 2) & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichner " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
Antwort 12 von TJ
Wowwwwwwwwww nigthy,
das werde ich nachher wenn ich zeit habe mal testen.Erstmal vieeeeeelllllllllennn Dank.
Melde mich.
Gruss
TJ
das werde ich nachher wenn ich zeit habe mal testen.Erstmal vieeeeeelllllllllennn Dank.
Melde mich.
Gruss
TJ
Antwort 13 von TJ
Hallölllleeee nighty,
so nu hatte ich etwas Zeit, Dein Proggi auf Herz und Nieren zu prüfen!!
Also erstmal nochmals vielllleeennnn Dank!!
Das läuft vorzüglich.
Aber nun kommt das aber:-)
Nehmen wir mal an wir haben den Artikel 123 am 20.10.03 sowie am 20.06.03 und sagen wir am 14.01.04 angelegt.
Dann löscht er den 14.01.04.
Bleibt man im Jahr 2003 läuft alles richtig, sowie es ins Neue Jahr geht löscht er den neuesten angelegten Artikel.
Ist das vielleicht auch noch zu lösen??
Ich hoffe, ich habe mich verständlich ausgedrückt.
Ansonsten kann ich nur sagen, dass ist echt eine tolle Hilfe für mich.
Einen schönen Tag wünscht
TJ
so nu hatte ich etwas Zeit, Dein Proggi auf Herz und Nieren zu prüfen!!
Also erstmal nochmals vielllleeennnn Dank!!
Das läuft vorzüglich.
Aber nun kommt das aber:-)
Nehmen wir mal an wir haben den Artikel 123 am 20.10.03 sowie am 20.06.03 und sagen wir am 14.01.04 angelegt.
Dann löscht er den 14.01.04.
Bleibt man im Jahr 2003 läuft alles richtig, sowie es ins Neue Jahr geht löscht er den neuesten angelegten Artikel.
Ist das vielleicht auch noch zu lösen??
Ich hoffe, ich habe mich verständlich ausgedrückt.
Ansonsten kann ich nur sagen, dass ist echt eine tolle Hilfe für mich.
Einen schönen Tag wünscht
TJ
Antwort 14 von nighty
hi tj :)
ops jetzt muesste besser sein .
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2)) & "1" & (Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichner " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
ops jetzt muesste besser sein .
gruss nighty
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
A = LastCell.Row
Do While Application.CountA(Rows(A)) = 0 And A <> 1
A = A - 1
Loop
alta = A
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
If Range("A" & t1%) = Range("A" & t%) And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2)) & "1" & (Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichner " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
Antwort 15 von nighty
hi tj
wenn noch was sein sollte schick mir email,es werden zu viele listings :)
gruss nighty
wenn noch was sein sollte schick mir email,es werden zu viele listings :)
gruss nighty
Antwort 16 von nighty
hi tj
hab mich wohl verfranzt,schick mir email :)
gruss nighty
hab mich wohl verfranzt,schick mir email :)
gruss nighty
Antwort 17 von TJ
Oki nighty
ist unterwegs:-)
Du gibst Dir echt viel Mühe.
Vielen Dank noch mal.
Gruss
TJ
ist unterwegs:-)
Du gibst Dir echt viel Mühe.
Vielen Dank noch mal.
Gruss
TJ
Antwort 18 von Aliba
Hallo TJ, hi nighty,
würde die ganze Sache etwas praktischer angehen. Es soll diese Datei ja nur einmal bereinigt werden und anschliessend soll verhindert werden, daß eine Art-Nr. doppelt angelegt wird.
Voraussetzung: Zeile 1 enthält Überschriften, wenn nicht einfach einfügen und beliebig benennen. Daten beginnen in Zeile 2.
Nun zuerst die daten nach Spalte C absteigend sortieren. (Überschriften beachten!)
Dann Spalte A komplett markieren.
DATEN - FILTER - SPEZIALFILTER (falls Fehlermeldung kommt einfach weiter), dann
sollte die Spalte A bereits vorgeschlagen werden. Nun nur noch Haken bei "an gleicher Stelle filtern" und Haken bei "keine Duplikate" . Fertig OK.
Gefiltertes ERgebnis kopieren und in ein neues Tabellenblatt einfügen.
Nun den Bereich A2 bis z.B. A20000 markieren (soviele Daten halt erwartet werden).
Dann DATEN - GÜLTIGKEIT - Benutzerdefiniert
Formel: =ZÄHLENWENN($A$2:A2;A2)=1
Unter dem Register Fehlermeldung: Stil: Stop
Titel: Aufgepasst Du Dödel!!
Fehlermeldung: Art.-Nr. existiert bereits. Abbrechen und andere Nr. eingeben
Die ganze Angelegenheit dauert vielleicht 2 Minuten und dann ists erledigt.
CU Aliba
würde die ganze Sache etwas praktischer angehen. Es soll diese Datei ja nur einmal bereinigt werden und anschliessend soll verhindert werden, daß eine Art-Nr. doppelt angelegt wird.
Voraussetzung: Zeile 1 enthält Überschriften, wenn nicht einfach einfügen und beliebig benennen. Daten beginnen in Zeile 2.
Nun zuerst die daten nach Spalte C absteigend sortieren. (Überschriften beachten!)
Dann Spalte A komplett markieren.
DATEN - FILTER - SPEZIALFILTER (falls Fehlermeldung kommt einfach weiter), dann
sollte die Spalte A bereits vorgeschlagen werden. Nun nur noch Haken bei "an gleicher Stelle filtern" und Haken bei "keine Duplikate" . Fertig OK.
Gefiltertes ERgebnis kopieren und in ein neues Tabellenblatt einfügen.
Nun den Bereich A2 bis z.B. A20000 markieren (soviele Daten halt erwartet werden).
Dann DATEN - GÜLTIGKEIT - Benutzerdefiniert
Formel: =ZÄHLENWENN($A$2:A2;A2)=1
Unter dem Register Fehlermeldung: Stil: Stop
Titel: Aufgepasst Du Dödel!!
Fehlermeldung: Art.-Nr. existiert bereits. Abbrechen und andere Nr. eingeben
Die ganze Angelegenheit dauert vielleicht 2 Minuten und dann ists erledigt.
CU Aliba
Antwort 19 von TJ
Hallöle Aliba,
vielen Dank für Deinen Lösungsvorschlag.
Den werde ich im Hinterkopf behalten und habe mir das kopiert!!
Ich denke mal, dass die Knopfdrucklösung von nighty für mich am praktischsten ist.
Zumal das Proggi ja auch fast fertig ist.
Stimmt....einige Dodels haben wir wirklich:-)
Einen schönen Abend wünscht
TJ
vielen Dank für Deinen Lösungsvorschlag.
Den werde ich im Hinterkopf behalten und habe mir das kopiert!!
Ich denke mal, dass die Knopfdrucklösung von nighty für mich am praktischsten ist.
Zumal das Proggi ja auch fast fertig ist.
Stimmt....einige Dodels haben wir wirklich:-)
Einen schönen Abend wünscht
TJ
Antwort 20 von nighty
hi aliba :)
ich habs endlich fehlerfrei :)
danke auch fuer deine ideen :)
gruss nighty
ich habs endlich fehlerfrei :)
danke auch fuer deine ideen :)
gruss nighty
Antwort 21 von TJ
Hi nighty,
auch auf diesem Wege möchte ich mich bedanken für das tolle Proggi.
Es läuft bis jetzt fehlerfrei aber hin und wieder schreibt er eine Zahlenkombination in e1 und e2, dass sieht wien Datum aus *2003112130*
*2004101130*
Das werfe ich immer raus und gut is.
Einen schönen Tag wünscht
TJ
auch auf diesem Wege möchte ich mich bedanken für das tolle Proggi.
Es läuft bis jetzt fehlerfrei aber hin und wieder schreibt er eine Zahlenkombination in e1 und e2, dass sieht wien Datum aus *2003112130*
*2004101130*
Das werfe ich immer raus und gut is.
Einen schönen Tag wünscht
TJ
Antwort 22 von nighty
hi tj :)
ops,das waren kontrollaugenblicke :)
diese zeilen loeschen :)
Range("e1") = Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2))
Range("e2") = Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2))
gruss nighty
ops,das waren kontrollaugenblicke :)
diese zeilen loeschen :)
Range("e1") = Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2))
Range("e2") = Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2))
gruss nighty
Antwort 23 von TJ
Hi nighty:-)
jaaaaaaaa danke werde das sogleich erledigen.
Es macht richtig spass mit dem Proggi zuarbeiten.
Weiterhin einen schönen Tag wünscht
TJ
jaaaaaaaa danke werde das sogleich erledigen.
Es macht richtig spass mit dem Proggi zuarbeiten.
Weiterhin einen schönen Tag wünscht
TJ