Makro verbesserung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hi,
habe mal mit Long ausprobiert, bricht zwar nicht gleich ab, aber nach 10 Minuten schiess ich Excel ab, da es einfach zu lange dauert.
jetzt muss ich doch noch mal lange ausholen, damit mein Problem mit dem Makro besser verstanden wird.
In meiner alten Datei habe ich bei jeder Zeile eine Wenn Abfrage Formel mit eine Bezug auf eine Zellen im Homesheet. Dh. es können zwei Beträge eingegeben werden und danach wird im Data sheet ein Ja oder nein berechnet. Auf das ganze Feld wird eine Pivot Tabelle gezogen. Damit kann man eigentlich ganz gut arbeiten.
Leider funktioniert aber die Pivot tabelle nur begrenzt, da ich bereits das Limit bei manchen Feldern erreicht habe, kann sie nicht mehr alles anzeigen.
Deshalb wollte ich die Sache anders angehen und nur die relevanten Daten in ein neues Sheet kopieren und darauf die Pivot laufen lassen, damit die Daten kleiner werden.
Die Leute sollten alles bekommen und danach einfach ihre range eingeben und das Makro sucht die entsprechenden Daten. Aber wenn das Makro 10 Minuten läuft macht es keinen Sinn mehr, da es einfach zu lange dauert.
Deshalb wollte ich fragen, ob das Makro noch optimiert werden kann, oder vielleicht hat jemand eine andere Lösung parat.
Gruss
Andre

Private Sub copy_Act_Sav() Dim ActSavprozentMin, ActSavprozentMax As Long Dim i As Long Dim LZDataRow As Long Dim Ziel As Worksheet, Quelle As Worksheet Dim LZData As Range Dim arrTmp(), n As Long Application.ScreenUpdating = False Application.Calculation = xlManual wb_ziel = ActiveWorkbook.Name ActSavprozentMin = Workbooks(wb_ziel).Worksheets("Home").Cells(2, 3) ActSavprozentMax = Workbooks(wb_ziel).Worksheets("Home").Cells(2, 4) Set Quelle = Workbooks(wb_ziel).Worksheets("Data") Set Ziel = Workbooks(wb_ziel).Worksheets("test") i = 1 Do Until Quelle.Cells(i, 1) = "" If (ActSavprozentMin > Quelle.Cells(i, 4)) _ Or (ActSavprozentMax

Sub copy_bestimmte_Zellen_kopieren() Dim ActSavprozentMin, ActSavprozentMax As Long Dim i As Long Dim LZDataRow As Long Dim Ziel As Worksheet, Quelle As Worksheet Dim LZData As Range Dim arrTmp(), n As Long Application.ScreenUpdating = False Application.Calculation = xlManual wb_ziel = ActiveWorkbook.Name ActSavprozentMin = Workbooks(wb_ziel).Worksheets("Home").Cells(2, 3) ActSavprozentMax = Workbooks(wb_ziel).Worksheets("Home").Cells(2, 4) Set Quelle = Workbooks(wb_ziel).Worksheets("Data") Set Ziel = Workbooks(wb_ziel).Worksheets("test") i = 1 Do Until Quelle.Cells(i, 1) = "" If (ActSavprozentMin > Quelle.Cells(i, 201)) _ Or (ActSavprozentMax

Hallo,
du willst immerhin 10.000.000 Zellen untersuchen.
Ohne die permante Redimensionierung dürfte es noch etwas schneller sein.

Sub copy_bestimmte_Zellen_kopieren()
Dim ActSavprozentMin, ActSavprozentMax As Long
Dim i As Long
Dim LZDataRow As Long
Dim Ziel As Worksheet, Quelle As Worksheet
Dim LZData As Range
Dim arrTmp(), n As Long, k As Integer
Const iColumns As Integer = 200
Application.ScreenUpdating = False
Application.Calculation = xlManual
With ActiveWorkbook
ActSavprozentMin = .Worksheets("Home").Cells(2, 3)
ActSavprozentMax = .Worksheets("Home").Cells(2, 4)
Set Quelle = .Worksheets("Data")
Set Ziel = .Worksheets("test")
End With
ReDim arrTmp(1 To iColumns, 1 To Application.CountA(Quelle.Columns(1)))
With Quelle
For i = 1 To .Cells(1, 1).End(xlDown)
Select Case .Cells(i, 201)
Case Is  ActSavprozentMax
n = n + 1
' Datenbereich aus Quelle selektieren und kopieren
For k = 1 To iColumns
arrTmp(k, n) = .Cells(i, k)
Next k
End Select
Next i
End With
ReDim Preserve arrTmp(1 To iColumns, 1 To n)
With Ziel
' Bezug auf erste Spalte Data ab A2 - nächste leere Zelle suchen
LZDataRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LZDataRow

Gruß
Rudi

Sub copy_bestimmte_Zellen_kopieren() Dim ActSavProzentMin, ActSavProzentMax As Long Dim Ziel As Worksheet, Quelle As Worksheet Dim rZiel As Range Const iColumns As Integer = 30 Application.ScreenUpdating = False Application.Calculation = xlManual With ActiveWorkbook ActSavProzentMin = .Worksheets("Home").Cells(2, 3) ActSavProzentMax = .Worksheets("Home").Cells(2, 4) Set Quelle = .Worksheets("Data") Set Ziel = .Worksheets("test") End With With Ziel If Application.CountA(.Columns(1)) = 0 Then Set rZiel = .Cells(1, 1) Else Set rZiel = .Cells(Rows.Count, 1).End(xlUp).Offset(1) End If End With With Quelle .Cells(1, 1).AutoFilter Field:=iColumns + 1, Criteria1:=">" & ActSavProzentMin, _ Operator:=xlAnd, Criteria2:=" 1 Then rZiel.EntireRow.Delete End With Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread