Microsoft Excel

Herbers Excel/VBA-Archiv

Makro .. durchführen bis Ende | Herbers Excel-Forum


Betrifft: Makro .. durchführen bis Ende von: Mike
Geschrieben am: 11.12.2009 11:32:22


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

  

Betrifft: Immer feste drauf klopfen / drucken... ;-) von: NoNet
Geschrieben am: 11.12.2009 11:43:50

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


  

Betrifft: AW: Immer feste drauf klopfen / drucken... ;-) von: Chris
Geschrieben am: 11.12.2009 11:54:34

*lol* Genial NoNet


  

Betrifft: wird schon geklopfen ... von: Mike
Geschrieben am: 11.12.2009 12:04:17


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


  

Betrifft: hört mal wer hier hämmert .. von: Mike
Geschrieben am: 11.12.2009 12:52:11


... ;-) ... 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


  

Betrifft: AW: hört mal wer hier hämmert .. von: Chris
Geschrieben am: 11.12.2009 13:22:51

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??


  

Betrifft: find a way .. von: Mike
Geschrieben am: 11.12.2009 13:41:33


... 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


  

Betrifft: AW: find a way .. von: Chris
Geschrieben am: 11.12.2009 13:52:00

und warum kann man sie nicht gleich löschen?


  

Betrifft: Direkter Weg .. von: Mike
Geschrieben am: 11.12.2009 14:00:34


Hey Chris,

das könnte natürlich auch direkt geschehen. Mein ursprünglicher
Code war eine Rekorder-Aufzeichnung .. ;-)

Gruss
Mike


  

Betrifft: AW: Direkter Weg .. von: Chris
Geschrieben am: 11.12.2009 14:08:37

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



  

Betrifft: Gebührend die Gebühren belassen.. von: Mike
Geschrieben am: 11.12.2009 14:19:22


Hey Chris,

danke für den Code, aber es muss ja nicht "Gebühren" etc. gelöscht
werden, sondern Zeilen darunter .. :-/

Gruss
Mike


  

Betrifft: Sledgehammer ? - Nicht nötig... von: NoNet
Geschrieben am: 11.12.2009 13:26:12

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


  

Betrifft: Hammer to fall ... von: Mike
Geschrieben am: 11.12.2009 13:38:57


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


  

Betrifft: Step by Step ... von: Mike
Geschrieben am: 11.12.2009 13:48:09


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


  

Betrifft: Sorry - dazu müsste ich Deine Tabelle kennen von: NoNet
Geschrieben am: 11.12.2009 14:02:12

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


  

Betrifft: klar doch .. von: Mike
Geschrieben am: 11.12.2009 14:15:49



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.


  

Betrifft: ists .. - dazu müsste ich Deine Tabelle kennen von: Mike
Geschrieben am: 12.12.2009 10:17:03


Hey NoNet,

ists nun mit der Datei verständlicher? Danke fürs Feedback.

Gruss
Mike


  

Betrifft: @NoNet ... ists von: Mike
Geschrieben am: 14.12.2009 08:10:52


Hey NoNet,

ist nun mit der Beispieldatei verständlicher?

Danke und Gruss, Mike