Supportnet Computer
Planet of Tech

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



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

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


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


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



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


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

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





Antwort 9 von nighty

hi tj :)

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






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


Antwort 12 von TJ

Wowwwwwwwwww nigthy,

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


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

Antwort 15 von nighty

hi tj

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

Antwort 17 von TJ

Oki nighty

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

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

Antwort 20 von nighty

hi aliba :)

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



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

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

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: