Tuning eines Makros
Kasimir
Ich bräuchte mal wieder Hilfe. Ich habe 2 Tabellenblätter. Eines mit Rechnungsdaten und eines Mit Rechnungspositionen. In beiden Tabellen gibt es eine Spalte mit Rechnungsnummern. Ich gehe nun Zeile für Zeile in dem Blatt mit den Positionen lese die Rechnungsnummer aus und suche diese im Rechnungsblatt. Wenn gefunden schreibe ich in das Blatt mit den Positionen das Rechnungsdatum, welches in der gleichen Zeile wie die gefundene Rechnungsnummer steht.
Im Moment erledige ich das mit nachfolgendem Code.
Modul Modul2
Option Explicit
Sub Auswertung()
Dim lngLastRow As Long
Dim lngLastRowRech_Pos As Long
Dim lngRowRechnung As Long
Dim strAddresse As String
Dim strSuchtext As String
Dim rngSuchbereich As Range
Dim dblSumme As Double
Dim dblSummeErtrag As Double
Dim wksRech_Pos As Worksheet
Dim wksRechnung As Worksheet
Dim wkbAktuelleDatei As Workbook
Dim dtStartime As Date
Dim dtEndtime As Date
'Startzeit ermitteln
dtStartime = Time
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ErrorCheckingOptions.BackgroundChecking = False
.CalculateBeforeSave = False
End With
Set wkbAktuelleDatei = ActiveWorkbook
Set wksRech_Pos = wkbAktuelleDatei.Sheets("Positionen")
Set wksRechnung = wkbAktuelleDatei.Sheets("Rechnung")
With wksRech_Pos
lngLastRowRech_Pos = .Cells(Rows.Count, 1).End(xlUp).Row
For lngRowRechnung = 2 To wksRechnung.Cells(Rows.Count, 1).End(xlUp).Row
'Text in Statusbar
Application.StatusBar = "Zeile Rechnung: " & lngRowRechnung
DoEvents
strSuchtext = wksRechnung.Cells(lngRowRechnung, 1)
Set rngSuchbereich = .Range("B1:B" & lngLastRowRech_Pos).Find(What:=strSuchtext, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not rngSuchbereich Is Nothing Then
strAddresse = rngSuchbereich.Address
Do
Application.StatusBar = "Zeile Rechnung: " & lngRowRechnung & " - Copy Datum"
DoEvents
'Datum kopieren
.Cells(rngSuchbereich.Row, 20) = wksRechnung.Cells(lngRowRechnung, 4)
Set rngSuchbereich = .Range("B1:B" & lngLastRowRech_Pos).FindNext(rngSuchbereich)
Loop While Not rngSuchbereich Is Nothing And rngSuchbereich.Address <> strAddresse
End If
Next
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.ErrorCheckingOptions.BackgroundChecking = True
.CalculateBeforeSave = True
.Calculate
.StatusBar = ""
End With
'Endzeit ermitteln
dtEndtime = Time
'Verstrichene Zeit erechnen
MsgBox "Dauer der Auswertung:" & vbLf & Format(dtEndtime - dtStartime, "hh:mm:ss"), vbInformation
End Sub
[size=8]Code eingefügt mit [url=http://vbahtml.origo.ethz.ch] VBA in HTML 2.0.0.3[/url][/size]
Der Funktioniert auch soweit. Allerdings dauert das Makro gute 45 Minuten, da es sich im Blatt mit den Positionen um ca. 75000 Zeilen und im Rechnungsblatt um ca. 25000 Zeilen handelt. Hat eventuell jemand einen kleinen Tuningtipp zu meinem Makro, so dass das Makro vielleicht nicht ganz so lange benötigt?
Danke Euch schon mal im Voruas für Eure Tipps,
Kasimir