Makro beschleunigen

Sub Bezahlt_markieren2() Dim RechnungsFeld, Listenfeld As Object Dim Awsheet As String Awsheet = ActiveSheet.Name Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Application.Calculation = xlManual ActiveWorkbook.Sheets("Liste").Activate For Each RechnungsFeld In Worksheets(Awsheet).Range("V10:V" & Worksheets(Awsheet).Cells. _ SpecialCells(xlCellTypeLastCell).Row) For Each Listenfeld In ActiveSheet.Range("V2:V" & ActiveSheet.Cells.SpecialCells( _ xlCellTypeLastCell).Row) If Listenfeld.Text = RechnungsFeld.Text Then 'If Listenfeld.Offset(0, 1) = RechnungsFeld.Offset(0, 1) Then ActiveSheet.Range("AL" & Listenfeld.Row) = "bez" ActiveSheet.Range("AM" & Listenfeld.Row) = Now 'End If End If Next Listenfeld Next RechnungsFeld Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic ActiveWorkbook.Sheets(Awsheet).Activate End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Bezahlt_markieren2() Dim RechnungsFeld As Range Dim Awsheet As Worksheet Set Awsheet = ActiveSheet For Each RechnungsFeld In Awsheet.Range("V10:V" & Awsheet.Cells.SpecialCells(xlCellTypeLastCell) _ .Row) With Sheets("Liste").Range("V:V") .Replace RechnungsFeld.Text, True, xlWhole If WorksheetFunction.CountIf(.Cells, True) > 0 Then With .SpecialCells(xlCellTypeConstants, 4) Intersect(.EntireRow, .Parent.Range("AL:AL")).Value = "bez" Intersect(.EntireRow, .Parent.Range("AM:AM")).Value = Now .Value = RechnungsFeld.Text End With End If End With Next End Sub

Hallo Lutz,
hier ein an deine Beispiel-Datei angepasstes Makro.
Laufzeit des Makros sollte jetzt max. 2 Sekunden sein. Ist natürlich abhängig von Rechner-Power und Auslastung des Rechners.
Weitere Beschleunigung bei der Ausführung des Makros besteht in der Sortierung von Blatt "Liste"
Wenn diese nach der Kunden-Nr oder dem Bezahl-Zeitpunkt sortiert ist, dann kann man die Suchschleife abbrechen, wenn alle Zeilen mit der abzugleichenden Kunden-Nr abgearbeitet sind, oder wenn in der Liste zur Kunden-Nr. die 1. Zeile mit "bez" auftaucht.
Gruß
Franz

Sub Bezahlt_markieren2()
Dim wksAktiv As Worksheet, wksListe As Worksheet
Dim ZeileAktiv As Long, ZeileListe As Long
Dim ZeileAktivL As Long, ZeileListeL As Long
Dim Zeit As Date, strKndNr As String
Set wksAktiv = ActiveSheet 'Rechnungsblatt / Prov
Set wksListe = Worksheets("Liste")
'Prüfen, ob Blatt "Liste" aktives Blatt
If wksAktiv.Name = wksListe.Name Then
MsgBox "Makro darf nicht gestartet werden, wenn Blatt ""Liste"" das aktive blatt ist",  _
_
vbInformation + vbOKOnly, "Makro: Bezahlt_markieren2"
GoTo Beenden
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlManual
End With
With wksAktiv 'Rechnungsblatt
'Letzte Zeile mit Daten in Spalte V (22)
ZeileAktivL = .Cells(.Rows.Count, 22).End(xlUp).Row
If ZeileAktivL >= 10 Then
'Kundennummer ermitteln
For ZeileAktiv = 10 To ZeileAktivL
With .Cells(ZeileAktiv, 22)
If Val(.Text) > 0 Then
strKndNr = .Text
Exit For
End If
End With
Next ZeileAktiv
Else
MsgBox "Keine Daten im aktiven Blatt Spalte V"
GoTo Beenden
End If
End With
If strKndNr = "" Then
MsgBox "Keine Kunden-Nr, in Spalte V im aktiven Blatt gefunden"
GoTo Beenden
End If
With wksListe 'Listenblatt
'Letzte Zeile mit Daten in Spalte V (22)
ZeileListeL = .Cells(.Rows.Count, 22).End(xlUp).Row
If ZeileListeL >= 2 Then
'.Activate
Zeit = Now
For ZeileListe = 2 To ZeileListeL
If .Cells(ZeileListe, 22).Text = strKndNr Then
'Prüfung, ob "bez" für Kunden-Nr. schon eingetragen
If .Cells(ZeileListe, 38).Value  "bez" Then
.Cells(ZeileListe, 38).Value = "bez"  'Spalte AL
.Cells(ZeileListe, 39).Value = Zeit   'Spalte AM
End If
End If
Next ZeileListe
Else
MsgBox "Keine Daten in Spalte V im Blatt ""Liste"""
End If
End With
Beenden:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlAutomatic
End With
wksAktiv.Activate
Set wksAktiv = Nothing
Set wksListe = Nothing
End Sub

Hallo Luc,
vielen Dank für Deine Hilfe - ich muß wohl sagen, dass ich den geposteten Code nicht selber geschrieben habe. D.h. ich kann Deine Tipps leider nicht ohne Hilfe umsetzen.
Hier noch mal etwas was ich eben Daniel geantwortet hatte:
vielen Dank für Deinen Tipp - vielleicht ist der Ablauf nicht ganz klar geworden:
Im aktiven Blatt suche ich nach einem Kunden und erstelle die Abrechnung. Die Drucke ich aus und der Kunde zahlt.
Nun muß im Blatt "Liste" genau nach diesem Kunden gesucht werden und seine Datensätze auf "bez" gesetzt werden.
Dann kommt der nächste Kunde und ich gehe wieder in das aktive Blatt und selektiere nach diesem Kunden... (nun würde die Formel aber bei dem Kunden aber nichts mehr finden und die Sätze wären wieder offen)
Der Sinn des Codes ist den gerade selekierten Kunden (der sich danach wieder ändert) im Blatt Liste zu suchen und alle seine Datensätze auf "bez" zu setzen (fest; im Blatt Liste dürfen/sollen keine Formeln sein da wird immer wieder etwas angehängt)
Was evt. Sinn machen wwürde ist im Blatt Liste am Anfang einen Autofilter zu setzen, dann nur noch die sichtbaren Datensätze durchzugehen und den Autofilter wieder zu entfernen - ich weiß aber nicht wie das per Makro geht.
Vielen Dank schon einmal und viele Grüße Lutz

Sub Bezahlt_markieren2() Dim RechnungsFelder, Listenfelder, L As Long, M As Long Dim Awsheet As String Awsheet = ActiveSheet.Name Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Application.Calculation = xlManual 'ActiveWorkbook.Sheets("Liste").Activate RechnungsFelder = Worksheets(Awsheet).Range("V10:V" & Worksheets(Awsheet).Cells. _ SpecialCells(xlCellTypeLastCell).Row).Value Listenfelder = ActiveWorkbook.Sheets("Liste").Range("V2:V" & ActiveWorkbook.Sheets("Liste") _ .Cells.SpecialCells( _ xlCellTypeLastCell).Row).Value Ausgabefelder = ActiveWorkbook.Sheets("Liste").Range("AL2:AM" & ActiveWorkbook.Sheets(" _ Liste").Cells.SpecialCells( _ xlCellTypeLastCell).Row).Value For L = LBound(RechnungsFelder, 1) To UBound(RechnungsFelder, 1) For M = LBound(Listenfelder, 1) To UBound(Listenfelder, 1) If Listenfelder(M, 1) = RechnungsFelder(L, 1) Then Ausgabefelder(M, 1) = "bez" Ausgabefelder(M, 2) = Now End If Next Listenfelder Next RechnungsFelder ActiveWorkbook.Sheets("Liste").Range("AL2:AM" & ActiveWorkbook.Sheets("Liste").Cells. _ SpecialCells( _ xlCellTypeLastCell).Row).Value = Ausgabefelder Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic 'ActiveWorkbook.Sheets(Awsheet).Activate End Sub

Beliebteste Forumthreads (12 Monate)

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread