AW: Excel VBA Daten Summieren
05.05.2020 11:27:39
fcs
Hallo Eric,
ich hab dir nachfolgendes Makro unter Verwendung von Daten-Arrays erstellt, um die Daten für Blatt "Ergebnisse" aufzubereiten.
Etwas unklar ist die Verarbeitung, wenn Eintrag für Multiplikator in Spalte D(?) erfolgt.
Ich hab die Auswertung so aufgebaut, dass die für das zugehörige Gebäude-Teil in den Zeilen darunter angegebenen Volumen für die Berechnung der Summen mit diesem Wert multipliziert werden.
Der große Vortei von Daten-Arrays ist, dass der Makroablauf wesentlich beschleunigt wird, weil dadurch viele Zugriffe auf einzelne Zellen vermieden werden können.
LG
Franz
Sub ErgebnisListe_ausfuellen()
Dim arrDaten
Dim zeiDaten As Long
Dim zei_1 As Long, zei_L As Long, zei As Long
Dim spa_k As Long
Dim arrErgebnis()
Dim arrKey()
Dim iKey As Integer
Dim sKey As String
Dim arrSpaKey(1 To 2) As Long
Dim dblMultipl As Double
Dim wks As Worksheet
If MsgBox("Daten nach Blatt ""Ergebnisse"" übertragen?", _
vbQuestion + vbOKCancel, "Fertig") = vbCancel Then Exit Sub
Set wks = ActiveWorkbook.Worksheets("Tabelle1")
'Schlüssel-Spalten
arrSpaKey(1) = 2 'Material
arrSpaKey(2) = 5 'Abfallcode
'Zellbereich mit Daten ermitteln und Daten in Array zwischenspeichern
With wks
zei_1 = 9 'Zeile mit dem 1. Gebäudeteil (Keller)
zei_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'alle Daten in den Spalten A bis F in Array laden
arrDaten = .Range(.Cells(zei_1, 1), .Cells(zei_L, 6))
End With
'Schlüsselwerte erfassen
ReDim arrKey(1 To UBound(arrDaten, 1), 1 To 2)
iKey = 0
For zeiDaten = 1 To UBound(arrDaten, 1)
If arrDaten(zeiDaten, 2) = "Material" Then
arrKey(zeiDaten, 2) = 9998 'Zeilen mit Material
'Prüfung, ob Multiplikatorzeile vorhanden
If Left(arrDaten(zeiDaten - 1, 2), 5) = "" Then 'kein Multiplikator
arrKey(zeiDaten - 1, 2) = 0
arrKey(zeiDaten - 1, 1) = 1
End If
ElseIf arrDaten(zeiDaten, 2) = "" Then
arrKey(zeiDaten, 2) = 9999 'markiert Leerzeilen
ElseIf Left(arrDaten(zeiDaten, 2), 5) = "Multi" Then
'Zeile mit Eintrag für Multiplikator
arrKey(zeiDaten, 2) = 0
If arrDaten(zeiDaten, 4) > 0 Then 'Multiplikator erfassen
arrKey(zeiDaten, 1) = arrDaten(zeiDaten, 4)
Else
arrKey(zeiDaten, 1) = 1
End If
Else
'Schlüsselwert mit Trennzeichen zu einem String zusammensetzen
sKey = arrDaten(zeiDaten, arrSpaKey(1))
For spa_k = 2 To UBound(arrSpaKey)
sKey = sKey & "|" & arrDaten(zeiDaten, arrSpaKey(spa_k))
Next
arrKey(zeiDaten, 1) = sKey
'Schlüssel mit Indexwert kennzeichnen
If iKey = 0 Then
iKey = 1
arrKey(zeiDaten, 2) = iKey
Else
For zei = 1 To zeiDaten - 1
If arrKey(zei, 1) = sKey Then
arrKey(zeiDaten, 2) = arrKey(zei, 2)
Exit For
End If
Next zei
If zei > zeiDaten - 1 Then
iKey = iKey + 1
arrKey(zeiDaten, 2) = iKey
End If
End If
End If
Next
If iKey = 0 Then
MsgBox "Keine Ergebnisse gefunden"
Exit Sub
End If
'Ergebnisarray dimensionieren
ReDim arrErgebnis(1 To iKey, 1 To 4) '4 spalten für ergebnisse
'Schlüsselwerte in Ergebnis-Array eintragen
For iKey = 1 To UBound(arrErgebnis, 1)
For zeiDaten = 1 To UBound(arrDaten, 1)
If arrKey(zeiDaten, 2) = iKey Then
For spa_k = 1 To UBound(arrSpaKey)
If arrDaten(zeiDaten, arrSpaKey(spa_k)) 0 Then
arrErgebnis(iKey, spa_k) = arrDaten(zeiDaten, arrSpaKey(spa_k))
End If
Next
If arrDaten(zeiDaten, 6) 0 Then
arrErgebnis(iKey, 3) = arrDaten(zeiDaten, 6) 'Entsorgungsweg?
End If
Exit For
End If
Next zeiDaten
Next iKey
'Mengen zu den Schlüsselwerten im Ergebnis-Array ermitteln
For zeiDaten = 1 To UBound(arrDaten, 1)
iKey = arrKey(zeiDaten, 2)
Select Case iKey
Case 0 'Multiplikator ist eingetragen
dblMultipl = arrKey(zeiDaten, 1)
Case Is > 9990 'Titel Material, Leerzeilen
'Zeilen überspringen
Case Else
arrErgebnis(iKey, 4) = arrErgebnis(iKey, 4) + dblMultipl * arrDaten(zeiDaten, 4)
End Select
Next zeiDaten
'Ergebnisse eintragen
Set wks = ActiveWorkbook.Worksheets("Ergebnisse")
With wks
zei_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Prüfen, ob alte Daten vorhanden sind
If zei_L > 1 Then
'vorhandene daten löschen
.Range(.Rows(2), .Rows(zei_L)).ClearContents
End If
'Ergebnisse ab Zelle A2 einfügen
.Range("A2").Resize(UBound(arrErgebnis, 1), 4) = arrErgebnis
.Activate
End With
'Variablen aufräumen
Erase arrDaten, arrErgebnis, arrKey, arrSpaKey
Set wks = Nothing
End Sub