HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal
Makro .. durchführen bis Ende
Mike


Hallo zusammen,
mit nachfolgendem Makro werden dreiseitige (Endlos)Importe passend gemacht.
Da die Liste immer länger wird, sollte das Makro nicht nur einmal ausgeführt werden,
sondern bis zum Schluss durchlaufen (aktuell starte ich es immer wieder mit F4).
Wie kann ich dies entsprechend anpassen?
Danke und Gruss, Mike
Sub AA_Worten_Gebühr_Prim_modifiziert()
' Nach_Worten_suchen Makro
' Makro am 20.04.2005 von Mike aufgezeichnet
' 05.03.07 keine Selects mehr
Cells.Find(What:="GEBÜHREN &", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, -2).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
'ActiveCell.Offset(1, 0).Range("A1")="x"
'ActiveCell.Offset(1, 0).Range("A1").Select
Cells.Find(What:="P R I M", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(-11, -2).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(6, 0).Range("A1") = "x"
ActiveCell.Offset(2, 0).Range("A1") = "x"
'ActiveCell.Offset(1, 0).Range("A1")="x"
'ActiveCell.Offset(1, 0).Range("A1")="x"
'ActiveCell.Offset(1, 0).Range("A1").Select
Cells.Find(What:="ÜBER- / UN", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(13, -2).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
ActiveCell.Offset(1, 0).Range("A1") = "x"
'ActiveCell.Offset(1, 0).Range("A1")="x"
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

Immer feste drauf klopfen / drucken... ;-)
NoNet

Hallo Mike,
unabhängig jeglicher Codeoptimierung kannst Du die redundanten Codezeile rausschmeißen :
ActiveCell.Offset(1, 0).Range("A1") = "x"
Diese Zeile muss nach jedem Cells.Find(...) - Vorgang nur einmal ausgeführt werden und nicht 14 mal.
Excel VBA ist ja nicht so steinzeitlich, dass man "immer feste drauf klopfen" muss (wie beim Steine meiseln), damit der Text in der Zelle stehen bleibt (das war früher bei Schreibmaschinen mit eingetrocknetem Farbband jedoch hilfreich, Texte mehrmals zu überdrucken ;-).
Um andere Codeoptimierungen durchzuführen, müsste man wissen, WAS Du genau erreichen möchtest....
Gruß, NoNet
AW: Immer feste drauf klopfen / drucken... ;-)
Chris

*lol* Genial NoNet
wird schon geklopfen ...
Mike

Hey NoNet,
durch die Modifiktion der ursprünglichen Zeilen (hier ein Ausschnitt)
ActiveCell.Offset(1, -2).Range("A1").Select
ActiveCell.FormulaR1C1 = "x"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "x"
...
gabs nun ein AnOrtKloppen ... grrr!
Zum Verständnis: Mit den x werden die Zeilen ausgezeichnet,
die dann später gelöscht werden (Autofilter - x - löschen).
Oder anders ausgedrückt, aus den ursprünglich drei
ausführlichen Seiten wird eine längere kompakte Seite.
Daher wäre es schön, wenn die Prozedur nicht nur einmal
ausgeführt wird, sondern bis ans Ende der Datei. Die aktuell
drei CellFinds werde ich dann auch noch auf einen reduzieren,
da ab dem ersten Find die weiteren Positionen von "PRIM" sowie
"Über/Unter" klar sind.
Danke für die Hilfe. Gruss, Mike
hört mal wer hier hämmert ..
Mike

... ;-) ... so, der Code modifiziert / entschlackt:
Sub AA_Worten_Gebühr_Prim_modifiziert()
' Nach_Worten_suchen Makro
' Makro am 20.04.2005 von Mike aufgezeichnet
' 05.03.07 keine Selects mehr
Cells.Find(What:="GEBÜHREN &", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, -2).Range("A1") = "x"
ActiveCell.Offset(2, -2).Range("A1") = "x"
ActiveCell.Offset(3, -2).Range("A1") = "x"
ActiveCell.Offset(4, -2).Range("A1") = "x"
ActiveCell.Offset(5, -2).Range("A1") = "x"
ActiveCell.Offset(6, -2).Range("A1") = "x"
ActiveCell.Offset(7, -2).Range("A1") = "x"
ActiveCell.Offset(8, -2).Range("A1") = "x"
ActiveCell.Offset(9, -2).Range("A1") = "x"
ActiveCell.Offset(10, -2).Range("A1") = "x"
ActiveCell.Offset(73, -2).Range("A1") = "x"
ActiveCell.Offset(74, -2).Range("A1") = "x"
ActiveCell.Offset(75, -2).Range("A1") = "x"
ActiveCell.Offset(76, -2).Range("A1") = "x"
ActiveCell.Offset(77, -2).Range("A1") = "x"
ActiveCell.Offset(78, -2).Range("A1") = "x"
ActiveCell.Offset(79, -2).Range("A1") = "x"
ActiveCell.Offset(80, -2).Range("A1") = "x"
ActiveCell.Offset(81, -2).Range("A1") = "x"
ActiveCell.Offset(87, -2).Range("A1") = "x"
ActiveCell.Offset(89, -2).Range("A1") = "x"
ActiveCell.Offset(129, -2).Range("A1") = "x"
ActiveCell.Offset(130, -2).Range("A1") = "x"
ActiveCell.Offset(131, -2).Range("A1") = "x"
ActiveCell.Offset(132, -2).Range("A1") = "x"
ActiveCell.Offset(133, -2).Range("A1") = "x"
ActiveCell.Offset(134, -2).Range("A1") = "x"
ActiveCell.Offset(135, -2).Range("A1") = "x"
ActiveCell.Offset(136, -2).Range("A1") = "x"
ActiveCell.Offset(137, -2).Range("A1") = "x"
ActiveCell.Offset(138, -2).Range("A1") = "x"
ActiveCell.Offset(139, -2).Range("A1") = "x"
ActiveCell.Offset(140, -2).Range("A1") = "x"
ActiveCell.Offset(141, -2).Range("A1") = "x"
ActiveCell.Offset(142, -2).Range("A1") = "x"
ActiveCell.Offset(143, -2).Range("A1") = "x"
End Sub

Jetzt wäre einfach noch die "Schlaufe" schön.
Danke für Eure Tipps.
Gruss
Mike
AW: hört mal wer hier hämmert ..
Chris

Also nochmal im Klartest was möchtest du erreichen?
Zeile in der in einer bestimmten Spalte entweder "P R I M" oder "GEBÜHREN" steht soll gelöscht werden, oder?
find a way ..
Mike

... to my idea .. ;-)
Hey Chris,
Das Suchen nach "Gebühren" ist der Ankerpunkt von
dem aus dann die überflüssigen Zeilen mit x markiert
werden.
Die x-Zeilen werden später mit dem Autofilter gelöscht.
Gruss
Mike
AW: find a way ..
Chris

und warum kann man sie nicht gleich löschen?
Direkter Weg ..
Mike

Hey Chris,
das könnte natürlich auch direkt geschehen. Mein ursprünglicher
Code war eine Rekorder-Aufzeichnung .. ;-)
Gruss
Mike
AW: Direkter Weg ..
Chris

Da gibt es einen Genialen Code von Thomas Ramel:
Du brauchst dann in dein Makro nur noch eingeben
Sub löschen
DelRows Range("A:A"), "GEBÜHREN" 'löscht Gebühren weil die doof sind :-)
DelRows Range("A:A"), "P R I M" 'löscht Primzahlen weil die auch doof sind :-)
End Sub 
Public Sub DelRows(rngSpalte As Range, varValue As Variant)
'© Thomas Ramel / 24.01.2005
'Funktion zum Löschen ganzer Zeilen eines Tabellenblattes unter
'Berücksichtigung von Kriterien
'Bedingung: nicht mehr als 8125 unzusammenhängende Bereiche als Ergebnis
'Die Funktion kann nur von VBA aufgerufen werden *nicht* in einer Zelle
'Folgender Aufruf löscht alle Zeilen wenn in Spalte A '10' enthalten ist:
'DelRows Range("A:A"), 10
Application.ScreenUpdating = False
Application.Calculation = xlManual
If Application.WorksheetFunction.CountIf(rngSpalte, varValue) > 0 Then
If varValue = "" Then
rngSpalte.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Else
With rngSpalte
.Replace "", "##@@##", xlWhole
.Replace varValue, "", xlWhole
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Replace "##@@##", "", xlWhole
End With
End If
End If
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

Gebührend die Gebühren belassen..
Mike

Hey Chris,
danke für den Code, aber es muss ja nicht "Gebühren" etc. gelöscht
werden, sondern Zeilen darunter .. :-/
Gruss
Mike
Sledgehammer ? - Nicht nötig...
NoNet

Hallo Mike,
dazu benötigt man keinen "Vorschlaghammer" (sledgehammer) sondern es genügt ein kleines "Hämmerchen" - zumindest wenn die Abstände immer fest sind :
Sub AA_Worten_Gebühr_Prim_modifiziert3()
' Nach_Worten_suchen Makro
' Makro am 20.04.2005 von Mike aufgezeichnet
' 05.03.07 keine Selects mehr
With Cells.Find(What:="GEBÜHREN &", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
.Offset(1, -2).Resize(10).Value = "x"
.Offset(73, -2).Resize(9).Value = "x"
.Offset(86, -2).Value = "x"
.Offset(89, -2).Value = "x"
.Offset(129, -2).Resize(15).Value = "x"
End With
End Sub
Oder sind das die durch den Autofilter angezeigten Zeilen ? Dann wäre diese universellere Methode sinnvoller :
Sub AA_Worten_Gebühr_Prim_modifiziert4()
' Nach_Worten_suchen Makro
' Makro am 20.04.2005 von Mike aufgezeichnet
' 05.03.07 keine Selects mehr
Dim lngEZ As Long, lngLZ As Long, lngS As Long
With Cells.Find(What:="GEBÜHREN &", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
lngS = .Column - 2  'Spalte
lngEZ = .Row + 1    'Erste Zeile, lngLZ = Letzte Zeile
lngLZ = .CurrentRegion.SpecialCells(xlCellTypeVisible).Find("*", searchdirection:= _
xlPrevious).Row
Range(Cells(lngEZ, lngS), Cells(lngLZ, lngS)).Value = "x"
End With
End Sub
Gruß, NoNet
Hammer to fall ...
Mike

Hey NoNet,
danke schon mal für die Modifikation, wird ja immer chicer. Der Hammer
fällt momentan jedoch erst einmal, sollte aber durchrauschen bis
Zeile 40'000.
Der Autofilter wird erst später angewandt zum Löschen der x.
Gruss
Mike
Step by Step ...
Mike

Hey NoNet,
die Vermutung liegt wohl nicht falsch, dass alle "GEBÜHREN"
abgearbeitet werden, das Makro aber aktuell stur an den
gleichen Positionen hämmert .. :-/
Gruss
Mike
Sorry - dazu müsste ich Deine Tabelle kennen
NoNet

Hey Mike,
kannst Du nicht mal deine Tabelle (oder eine modifizierte DEMO-Version) hochladen ?
Das würde mir/uns die Arbeit erheblich erleichtern, da niemand den Aufbau Deiner Tabelle kennt...
Gruß, NoNet
klar doch ..
Mike

Hey NoNet,
klar doch, siehe im Anhang eine massiv verkürzte Version
der Importdaten -> https://www.herber.de/bbs/user/66525.xls
Danke und Gruss, Mike
<b>PS:</b> bin nachher leider weg, weitere Feedbacks kommen
morgen früh, danke für die Bemühungen.
ists .. - dazu müsste ich Deine Tabelle kennen
Mike

Hey NoNet,
ists nun mit der Datei verständlicher? Danke fürs Feedback.
Gruss
Mike
@NoNet ... ists
Mike

Hey NoNet,
ist nun mit der Beispieldatei verständlicher?
Danke und Gruss, Mike