AW: du solltest vielleicht...
08.10.2021 10:11:11
Werner
Hallo,
hier noch eine Codeänderung. Berechnet die Summe direkt, ohne den Umweg über eine Formel (ist ja unnötig).
Option Explicit
Public Sub WerteVerteilen()
'Unter Extras Verweise bitte Microsoft Scripting Runtime aktivieren
Dim wsQ As Worksheet, lRow As Long, lCol As Integer, loLetzte As Long
Dim arr As Variant, dic As Object, i As Long, wert As String
Dim rngDaten As Range, rngKriterien As Range, rngAusgabe As Range
Set wsQ = Sheets("GK_H")
Set dic = CreateObject("Scripting.Dictionary")
wsQ.Cells(1, 2) = "x"
wsQ.Cells(1, 3) = "xx"
wsQ.Cells(1, 4) = "xxx"
wsQ.Cells(1, 5) = "xxxx"
lRow = Cells(Rows.Count, 2).End(xlUp).Row
lCol = 5
arr = Range(Cells(2, 1), Cells(lRow, 2))
For i = LBound(arr) To UBound(arr)
dic(arr(i, 1)) = 0
Next
arr = WorksheetFunction.Transpose(dic.Keys)
Set rngDaten = wsQ.Range(Cells(1, 1), Cells(lRow, lCol))
Set rngKriterien = wsQ.Range("J1:J2")
wsQ.Range("J1") = "Klasse"
For i = LBound(arr, 1) To UBound(arr)
wert = arr(i, 1)
If wert "" Then
wsQ.Range("J2") = wert
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = wert
Set rngAusgabe = ActiveSheet.Range("A1")
rngDaten.AdvancedFilter xlFilterCopy, rngKriterien, rngAusgabe
Range("B1:E1").Clear
loLetzte = Cells(Rows.Count, "E").End(xlUp).Row
Range("E2:E" & loLetzte + 1).NumberFormat = "0.00%"
Cells(1, "ZZ") = 100
Cells(1, "ZZ").Copy
Range("E2:E" & loLetzte).PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Range("E" & loLetzte + 1) = WorksheetFunction.Sum(Range("E2:E" & loLetzte))
Cells(1, "ZZ").ClearContents
Cells().Columns.AutoFit
End If
Next i
wsQ.Range("J1:J2").Clear
wsQ.Range("B1:E1").Clear
Set wsQ = Nothing: Set dic = Nothing: Set rngDaten = Nothing: Set rngKriterien = Nothing: Set rngAusgabe = Nothing
End Sub
Zu deiner Frage:
Das ist eine Schleife über die einzelnen Werte im Array.
Gruß Werner