MIN/MAX VBA Performance
28.09.2018 17:37:28
Jack
hier etwas für Spezialisten.
In der folgenden Datei gibt es n Zeilen mit jeweils 4 Leveln / Titeln und einem Datum am Ende auf Level 4. Level 1-3 können mehrfach vorkommen. Ziel ist es für Level 1-3 das jeweilige Min-Max Datum von Level 4 zu evaluieren (s. Beispieldatei).
Ich habe bislang eine Formel eingesetzt z.B. "{=MIN(WENN((($J:$J=$J2));$S:$S))}". Diese ist aber leider bei der Masse an Daten inperformant. Daher habe ich es mit folgendem VBA versucht, welche auch in der Datei enthalten ist. Doch auch hier ist die Performance leider unterirdisch. Die grundsätzliche Funktionalität ist aber super.
Könnt ihr mir helfen für das Szenario eine performate Lösung zu bekommen?
Beispiel-Datei
https://www.dropbox.com/s/3c91umpbbz2hgdm/test02.xlsm?dl=0
VBA
Option Explicit
Sub Schaltfläche_Auswerten()
Dim arrDaten(), aZ As Long, larr As Long
larr = 0
'# Rechnungen
'## Titel 1 Von / Bis
With Sheets("Output")
'Range definieren
For aZ = 2 To Sheets("Output").Range("a" & Rows.Count).End(xlUp).Row
'Formel eintragen
Sheets("Output").Range("c2").FormulaArray = "=IF(RC[-2]="""",""-"",IF(MIN(IF(((C1=RC1)*(C18"""")),C18))=0,""-"",MIN(IF(((C1=RC1)*(C18"""")),C18))))"
'{=MIN(WENN((($J:$J=$J2));$S:$S))}
Sheets("Output").Range("d2").FormulaArray = "=IF(RC[-3]="""",""-"",IF(MAX(IF(C1=RC1,C19))=0, _
""-"",MAX(IF(C1=RC1,C19))))"
'{=MAX(WENN((($J:$J=$J2));$S:$S))}
'Kopieren
Sheets("Output").Range("c2:d2").Copy
Worksheets("Output").Cells(aZ, 3).Select
ActiveSheet.Paste
'Als Text einfügen
Sheets("Output").Range("c2:d2").EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End With
Sheets("Output").Range("c2:d" & larr + 1).NumberFormat = "dd.MM.yyyy" 'FormatDate
'## Titel 2 Von / Bis
With Sheets("Output")
'Range definieren
For aZ = 2 To Sheets("Output").Range("a" & Rows.Count).End(xlUp).Row
'Formel eintragen
Sheets("Output").Range("g2").FormulaArray = "=IF(RC[-2]="""","""",IF(MIN(IF(((C1=RC1)*(C18 _
"""")*(C5=RC5)),C18))=0,"""",MIN(IF(((C1=RC1)*(C18"""")*(C5=RC5)),C18))))"
Sheets("Output").Range("h2").FormulaArray = "=IF(RC[-3]="""","""",IF(MAX(IF(((C1=RC1)*(C18 _
"""")*(C5=RC5)),C19))=0,"""",MAX(IF(((C1=RC1)*(C18"""")*(C5=RC5)),C19))))"
'Kopieren
Sheets("Output").Range("g2:h2").Copy
Worksheets("Output").Cells(aZ, 7).Select
ActiveSheet.Paste
'Als Text einfügen
Sheets("Output").Range("g2:h2").EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End With
Sheets("Output").Range("g2:h" & larr + 1).NumberFormat = "dd.MM.yyyy" 'FormatDate
'## Titel 3 Von / Bis
With Sheets("Output")
'Range definieren
For aZ = 2 To Sheets("Output").Range("a" & Rows.Count).End(xlUp).Row
'Formel eintragen
Sheets("Output").Range("k2").FormulaArray = "=IF(RC[-2]="""","""",IF(MIN(IF(((C1=RC1)*(C18 _
"""")*(C5=RC5)*(C9=RC9)),C18))=0,"""",MIN(IF(((C1=RC1)*(C18"""")*(C5=RC5)*(C9=RC9)),C18))))"
Sheets("Output").Range("l2").FormulaArray = "=IF(RC[-3]="""","""",IF(MAX(IF(((C1=RC1)*(C18 _
"""")*(C5=RC5)*(C9=RC9)),C19))=0,"""",MAX(IF(((C1=RC1)*(C18"""")*(C5=RC5)*(C9=RC9)),C19))))"
'Kopieren
Sheets("Output").Range("k2:l2").Copy
Worksheets("Output").Cells(aZ, 11).Select
ActiveSheet.Paste
'Als Text einfügen
Sheets("Output").Range("k2:l2").EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End With
Sheets("Output").Range("k2:l" & larr + 1).NumberFormat = "dd.MM.yyyy" 'FormatDate
End Sub
Danke &
beste Grüße,
Jack