Makro sehr langsam

Hallo Zusammen,
folgende Beispiel-Datei habe ich beigefügt:
https://www.herber.de/bbs/user/33199.xls
Es ist nur eine Test-Datei mit Musterdaten (abgespeckt).
In der Tabelle Zusammenfassung befinden sich sonst ca. 2500 Zeilen.
In der Tabelle S+P und TPo jeweils sonst ca. 6000 - 12000 Zeilen.
Bei allen Tabellen handelt es sich um Daten, die sich
monatlich ändern.
Es muss jedoch monatlich ein Vergleich vollzogen werden,
deshalb habe ich das beiliegende Makro entworfen.
Das Makro läuft jedoch zwischen 15 Minuten und 20 Minuten.
Ist das Makro zu umständlich? Falsch geschrieben?
Gibt es eine Möglichkeit es zu beschleunigen?
Wie gesagt, 15 bis 20 Minuten Laufzeit ist jedoch ziemlich lange, oder?
Über eine Hilfestellung, Änderung des Makros, oder Lösungen wäre ich dankbar.
Vielen Dank im voraus.
Viele Grüsse
Uwe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Uwe!
Ich weis jetzt nicht, ob ich alles richtig umgesetzt habe, aber
das sollte ein gutes stück schneller laufen!

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Berechnungen_durchfuehren()

Dim wksZus As Worksheet
Dim wksAbt As Worksheet
Dim vorhanden As Boolean
Dim Bereich As Range
Dim TextAbt As String
Dim TextZus As String
Dim i As Integer
Dim k As Integer
Dim ZeileAbt As Integer
Dim ZeileZus As Integer
Dim Zelle As Range
Dim SpPN As Integer 'PersNr.
Dim SpLA As Integer 'Lohnart
Dim SpFK As Integer 'FibuKto
Dim SpKS As Integer 'KSt.
Dim Boxtext As String
Dim wkszusa As Worksheet
Dim wkssup As Worksheet
Dim wksTPO As Worksheet
Dim ZeileSuP As Integer
Dim SpFKSuP As Integer
Dim SpFKZusa As Integer
Dim SpPNzusa As Integer
Dim SpKSzusa As Integer
Dim ZeileTPO As Integer
Dim SpFKTPO As Integer
Dim SuPZusa As Integer
Dim TPOZusa As Integer
Dim SpPNSuP As Integer
Dim SpKSSuP As Integer
Dim spbesup As Integer
Dim SpPNTPO As Integer
Dim SpKSTPO As Integer
Dim SpBeTPO As Integer
Dim DifferenzenZusa As Integer
Dim j As Date
Dim Start As Double
Dim summe As Double

Dim rng As Range, rngF As Range, strFirst As String

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

Start = Timer

Debug.Print " gestartet um: " & Format(Now - j, "hh:mm:ss")

Set wkssup = ThisWorkbook.Sheets("S+P")
Set wkszusa = ThisWorkbook.Sheets("Zusammenfassung")
Set wksTPO = ThisWorkbook.Sheets("TPO")

'**********************************************************************************************************************************
'Tabelle: Zusammenfassung
'Spalte "PersNr"; Konto" "KoStNr" ausfindig machen
'Anzahl Zeilen ausfindig machen
'**********************************************************************************************************************************

With wkszusa
  Set Bereich = .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
End With

SpFKZusa = 0
SpPNzusa = 0
SpFKZusa = 0
SpKSzusa = 0

For Each Zelle In Bereich

  Select Case Zelle.Value

    Case "Konto"
      SpFKZusa = Zelle.Column
    Case "PersNr"
      SpPNzusa = Zelle.Column
    Case "KoStNr"
      SpKSzusa = Zelle.Column
    Case "S+P"
      SuPZusa = Zelle.Column
    Case "TPO"
      TPOZusa = Zelle.Column
    Case "Differenzen"
      DifferenzenZusa = Zelle.Column


  End Select
Next Zelle

ZeileZus = wkszusa.Cells(Rows.Count, SpFKZusa).End(xlUp).Row

'**********************************************************************************************************************************
'Tabelle: S+P
'Spalte "PersNr"; Konto" "KoStNr" ausfindig machen
'Anzahl Zeilen ausfindig machen
'**********************************************************************************************************************************

With wkssup
  Set Bereich = .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
End With

SpFKSuP = 0
SpPNSuP = 0
SpFKSuP = 0
SpKSSuP = 0

For Each Zelle In Bereich

  Select Case Zelle.Value

    Case "Konto"
      SpFKSuP = Zelle.Column
    Case "PersNr"
      SpPNSuP = Zelle.Column
    Case "KoStNr"
      SpKSSuP = Zelle.Column
    Case "Betrag"
      spbesup = Zelle.Column


  End Select
Next Zelle

'**********************************************************************************************************************************
'Tabelle: TPO
'Spalte "PersNr"; Konto" "KoStNr" ausfindig machen
'Anzahl Zeilen ausfindig machen
'**********************************************************************************************************************************

With wksTPO
  Set Bereich = .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
End With

SpFKTPO = 0
SpPNTPO = 0
SpFKTPO = 0
SpKSTPO = 0

For Each Zelle In Bereich

  Select Case Zelle.Value

    Case "Konto"
      SpFKTPO = Zelle.Column
    Case "PersNr"
      SpPNTPO = Zelle.Column
    Case "KoStNr"
      SpKSTPO = Zelle.Column
    Case "Betrag"
      SpBeTPO = Zelle.Column
  End Select

Next Zelle

'**********************************************************************************************************************************
'Tabelle: Zusammenfassung
'Spalte "S+P"
'Summe bilden
'**********************************************************************************************************************************

With wkszusa
  For Each rng In .Range(.Cells(2, SpFKZusa), .Cells(ZeileZus, SpFKZusa))
    If rng <> "" Then
      summe = 0
      Set rngF = wkssup.Columns(SpFKSuP).Find(rng)

      If Not rngF Is Nothing Then
        strFirst = rngF.Address
        Do
          If .Cells(rng.Row, SpPNzusa).Value = wkssup.Cells(rngF.Row, SpPNSuP).Value And _
            .Cells(rng.Row, SpKSzusa).Value = wkssup.Cells(rngF.Row, SpKSSuP).Value Then
            summe = summe + wkssup.Cells(rngF.Row, spbesup).Value
          End If
          Set rngF = wkssup.Columns(SpFKSuP).FindNext(rngF)

        Loop While Not rngF Is Nothing And rngF.Address <> strFirst
      End If
      wkszusa.Cells(rng.Row, SuPZusa).Value = summe
    End If
  Next
End With

'**********************************************************************************************************************************
'Tabelle: Zusammenfassung
'Spalte "TPO"
'Summe bilden
'**********************************************************************************************************************************

With wkszusa
  For Each rng In .Range(.Cells(2, SpFKZusa), .Cells(ZeileZus, SpFKZusa))
    If rng <> "" Then
      summe = 0
      Set rngF = wksTPO.Columns(SpFKTPO).Find(rng)

      If Not rngF Is Nothing Then
        strFirst = rngF.Address
        Do
          If .Cells(rng.Row, SpPNzusa).Value = wksTPO.Cells(rngF.Row, SpPNTPO).Value And _
            .Cells(rng.Row, SpKSzusa).Value = wksTPO.Cells(rngF.Row, SpKSTPO).Value Then
            summe = summe + wksTPO.Cells(rngF.Row, SpBeTPO).Value
          End If
          Set rngF = wksTPO.Columns(SpFKTPO).FindNext(rngF)

        Loop While Not rngF Is Nothing And rngF.Address <> strFirst
      End If
      wkszusa.Cells(rng.Row, TPOZusa).Value = summe
    End If
  Next
End With

Debug.Print " beendet um: " & Format(Now - j, "hh:mm:ss")

Debug.Print Format(Timer - Start, "#0.00") & " Sekunden gerödelt!"

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread