2 Seiten vergleichen und falsches lösche
08.09.2022 17:14:59
Igor
Ich möchte 2 Blätter vergleichen und die "Leichen" entfernen. Auf der 1. Seite das, was richtig ist und auf die 2. sind einige überflüssig.
Ich wollte mindestens mit "002" anfangen, aber trotzdem stecken geblieben und komme nicht weiter.
Die fertige Tabelle ist hier:
https://www.herber.de/bbs/user/155062.xlsm
Der Makro-Code (sehr schlecht wahrscheinlich!):
Sub Ueberfluessige_loeschen()
Dim SuchenNr As String
Dim objZiffern, objZiffernNr, objNummer002, cell, rng As Range
'wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
' Das später löschen:
Sheets("Original zum Kopieren").Select
Range("A1:A50").Select
'Range("B85").Activate
Selection.Copy
Sheets("nOK").Select
Range("A1").Select
ActiveSheet.Paste
'wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
ZeilenAnzahl = Cells(1048576, 1).End(xlUp).Row
' ";;002 - ab hier anfangen!
Set objNummer002 = Cells.Find(What:=";;002 ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set rng = Range("A7:A" & ZeilenAnzahl)
' A Anfang ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For Each cell In rng ' schlechte Schleife, weil immer sucht!
' B Anfang ---------
If objNummer002 Is Nothing Then
'nichts machen.
Else
Sheets("nOK").Select
Cells.Find(What:=";;002 ", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'offset 2 zellen nach rechts (C-Spalte):
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "=MID(RC[-2],7,14)" ' ab 6-8 15 Zeichen.
SuchenNr = ActiveCell.Value
Selection.Copy
Sheets("OK").Select
Set objZiffern = Cells.Find(What:=SuchenNr, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
' C Anfang ---------
If objZiffern Is Nothing Then
Sheets("nOK").Select
'"=TEIL(): ' 002-Zeile löschen:
Stop
ActiveCell.EntireRow.Delete Shift:=xlUp
Range("A1").Select
' Hier soll Schleife sein, weil weniger als 005 seien können!
' Schleifen Beispiele zur Auswahl:
Set objZiffernNr = Cells.Find(What:=SuchenNr, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
' D Anfang ---------
objZiffernNr = SuchenNr
While objZiffernNr = SuchenNr ' fast OK
'While Not objZiffernNr Is Nothing ' ?
'While objZiffernNr Is Not Nothing ' ?
MsgBox "Es wird weiter " & SuchenNr & " gesucht."
'''If Not obj Is Nothing Then
'''End If
' Hier wird Fehler, wenn nichts mehr gefunden wird:
' Bei Fehler RAUSPRINGEN:
On Error GoTo SucheBeendet
' Warum springt nicht raus bei 67?
Cells.Find(What:=SuchenNr, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
' zuerst ";;001" oder ";;003" wird gelöscht.
Stop
ActiveCell.EntireRow.Delete Shift:=xlUp
Wend
' D ENDE ---------
Stop
SucheBeendet:
Stop
''' Do Until objNummer002 = True ' wenn vorhanden, dann löschen:
''' Stop
''' ' Hier auch Fehler und muss man rausspringen:
''' Cells.Find(What:=SuchenNr, After:=ActiveCell, LookIn:=xlFormulas, _
''' LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
''' MatchCase:=False, SearchFormat:=False).Activate
''' Selection.ClearContents
''' Loop
'''Stop
''' 'Do While SuchenNr ""
''' Do While objNummer002 = False ' springt nicht rein
''' Stop
''' Loop
'Stop
' Do
' If SuchenNr = True Then
' Stop
' Exit Do
' End If
' Loop
'Stop
'in 002.):
''' Cells.Find(What:=SuchenNr, After:=ActiveCell, LookIn:=xlFormulas _
''' , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
''' MatchCase:=False, SearchFormat:=False).Activate
''' ActiveCell.EntireRow.Delete Shift:=xlUp
''' 'in 003.):
''' Cells.FindNext(After:=ActiveCell).Activate
''' ActiveCell.EntireRow.Delete Shift:=xlUp
''' 'in 004.):
''' Cells.FindNext(After:=ActiveCell).Activate
''' ActiveCell.EntireRow.Delete Shift:=xlUp
''' 'in 005.):
''' Cells.FindNext(After:=ActiveCell).Activate
''' ActiveCell.EntireRow.Delete Shift:=xlUp
Else
Sheets("nOK").Select
Selection.ClearContents ' in C-Spalte
' alle sind entfernt:
GoTo RausSpringen ' hier wäre besser Schleife
End If
' C ENDE ---------
'SucheBeendet:
' Stop ' fast OK, aber nur 2 Zahlen weg.
End If
' B ENDE ---------
' Stop
Next ' weiter suchen nach ";;001..."
' A ENDE ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RausSpringen:
MsgBox "Fertig!"
End Sub
Eigentlich die Schleifen sind irgendwie vermutlich falsch, aber... ich kann nicht besser was entwickeln.
Vielen Dank für Eure Hilfe!!!