|
Hallo Allerseits,
mein Problem ist folgendes: Ich filtere eine alphabetisch Sortierte Tabelle nach einem bestimmten Kriterium. Zu diesem Kriterium gehören zB. 8 Einträge. Nun will ich Charts automatisch generieren die mir 15-18 Einträge ausgibt und das gebündelt nach dem Kriterium. Das sollte dann so in etwa sein:
-
Kriterium 1: 4 Einträge
-
Kriterium 2: 6 Einträge
-
Kriterium 3: 6 Einträge
-
Kriterium 4: 15 Einträge => Wird in diesem Chart nicht mehr angezeigt
-
Kriterium 5: 17 Einträge
-
Kriterium 6: 9 Einträge
-
Kriterium 7 14 Einträge
Chart 1 fasst 16 Einträge von Kriterium 1-3
Chart 2 fasst 15 Einträge von Kriterium 4
Chart 3 fasst 17 Einträge von Kriterium 5
Chart 4 fasst 9 Einträge von Kriterium 6 & 6 Einträge von Kriterium 7
Chart 5 fasst restlichen 7 Einträge von Kriterium 7 & 8 Einträge von Kriterium xy
usw...
Ich habe das ganze bereits als Code versucht, jedoch sobald das Kriterium zuviele Einträge hat, ist das Chart entweder mit 18+ Werten voll oder mit fast keinen.
Hier sind die Code Teile:
MainClass:
Sub Balk_Report()
Dim bu, aBu As Integer
Dim buDict As Dictionary
Dim i As Integer
Dim filterArray() As String
Dim ueberschuss As Integer, used As Integer
Dim kennNummer As Integer
Dim index As Integer
Dim values As Range
Dim header As String
' Popupboxes unterdrücken
Application.DisplayAlerts = False
Set buDict = New Scripting.Dictionary
buDict.CompareMode = BinaryCompare
buDict.RemoveAll
index = 0
' Clear the HelperTable Values
Sheets("HelperTable").Visible = True
Sheets("HelperTable").Select
ActiveSheet.AutoFilterMode = False
Cells.Select
DeleteBorder
Selection.Delete Shift:=xlUp
Sheets("MainTable").Select
Call SortByKriterium
For Each brs In BRSDict
Set aBrs = BRSDict(brs)
If aBrs.State <> "rejected" Then
If Not buDict.Exists(aBrs.ST_BU) Then
buDict.Add aBrs.ST_BU, Count_BRS_for_BUs(aBrs.ST_BU)
End If
End If
Next
Set buDict = SortDictKeys(buDict)
ReDim filterArray(buDict.Count)
Do While buDict.Count <> 0
For Each bu In buDict
Starting:
aBu = buDict.Item(bu)
If i >= 15 Then
If ueberschuss = 0 Then
ReDim Preserve filterArray(index - 1)
' Setze den Filter
ActiveSheet.Range("A1:H" & Range("H1").End(xlDown).row).AutoFilter Field:=3, Criteria1:=filterArray, Operator:=xlFilterValues
' Kopiere alle sichtbaren Zeilen
'Set mergedRange = Union(Range("A1:B" & Range("B1").End(xlDown).row), Range("E1:H" & Range("H1").End(xlDown).row))
' Headline A1:B1 Headline E1:H1 First Value in Ax to Last Row in B First Value in Ex to Last Row in H
Set mergedRange = Union(Range("A1:B1"), Range("E1:H1"), Range(FilterErsteZelle(used), Range("B1").End(xlDown)), Range(Range("E" & FilterErsteZelle(used).row), Range("H1").End(xlDown)))
''' Set mergedRange = Union(Range("A1:B1"), Range("E1:H1"), Range(FilterErsteZelle(used), Range("B" & FilterLetzteZelle(ueberschuss))), Range(Range("E" & FilterErsteZelle(used).row), Range("H" & FilterLetzteZelle(ueberschuss))))
mergedRange.Select
Selection.Copy
' als Übergabe Parameter den Header, die letzte Reihe und anzahl der Rows
Call DisplayHelperTable(header)
Sheets("MainTable").Select
ReDim filterArray(buDict.Count)
index = 0
i = 0
header = ""
Else
ReDim Preserve filterArray(index - 1)
' Setze den Filter
ActiveSheet.Range("A1:H" & Range("H1").End(xlDown).row).AutoFilter Field:=3, Criteria1:=filterArray, Operator:=xlFilterValues
' Kopiere alle sichtbaren Zeilen
' Set mergedRange = Union(Range("A1:B" & Range("B1").End(xlDown).row), Range("E1:H" & Range("H1").End(xlDown).row))
'Set mergedRange = Union(Range("A1:B1"), Range("E1:H1"), Range("A" & used + 1 & ":B" & Range("B" & used + 1).End(xlDown).row), Range("E" & used + 1 & ":H" & Range("H" & used + 1).End(xlDown).row))
Set mergedRange = Union(Range("A1:B1"), Range("E1:H1"), Range(FilterErsteZelle(used), Range("B" & FilterLetzteZelle(ueberschuss))), Range(Range("E" & FilterErsteZelle(used).row), Range("H" & FilterLetzteZelle(ueberschuss))))
mergedRange.Select
Selection.Copy
' als Übergabe Parameter den Header, die letzte Reihe, Anzahl der Rows und Kennnummer
Call DisplayHelperTable(header)
Sheets("MainTable").Select
ReDim filterArray(buDict.Count)
index = 0
i = 0
header = ""
End If
End If
If i < 15 Then
If (i + aBu) <= 15 Then
filterArray(index) = bu
i = i + aBu
header = header & bu & " | "
buDict.Remove (bu)
index = index + 1
ueberschuss = 0
ElseIf i + aBu <= 18 Then
filterArray(index) = bu
i = i + aBu
header = header & bu & " | "
buDict.Remove (bu)
index = index + 1
ueberschuss = 0
ElseIf i + aBu > 15 Then
used = 0
filterArray(index) = bu
' soviele werden verwendet
used = 15 - i
header = header & bu & " x/y" & " | "
' soviele sind noch zu verwenden
ueberschuss = 15 - i
ueberschuss = aBu - ueberschuss
buDict.Item(bu) = ueberschuss
i = 15
index = index + 1
GoTo Starting
End If
End If
Next
Loop
' Ausgabe der letzten BU's
ReDim Preserve filterArray(index - 1)
' Setze den Filter
'ActiveSheet.Range(Cells(1, 1), Cells(Cells(1, 8).End(xlDown), 8)).AutoFilter Field:=3, Criteria1:=filterArray, Operator:=xlFilterValues
ActiveSheet.Range("$A$1:$H$149").AutoFilter Field:=3, Criteria1:=filterArray, Operator:=xlFilterValues
' Kopiere alle sichtbaren Zeilen
Set mergedRange = Union(Range("A1:B" & Range("B1").End(xlDown).row), Range("E1:H" & Range("H1").End(xlDown).row))
mergedRange.Select
Selection.Copy
' gehe ins Worksheet an die letzte freie Position
Call DisplayHelperTable(header)
Sheets("MainTable").Select
Sheets("HelperTable").Visible = False
buDict.RemoveAll
Set buDict = Nothing
' Popupboxes erlauben
Application.DisplayAlerts = True
End Sub
Methoden für Zellen mit den ersten/letzten Values:
Function FilterErsteZelle(zuviele As Integer) As Range
Dim rngSrc As Range, rngDst As Range
If ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode Then
Set rngSrc = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
If rngSrc.Areas(1).Rows.Count > 1 Then
Set rngDst = rngSrc.Areas(1).Cells(2, 1)
ElseIf rngSrc.Areas.Count > 1 Then
Set rngDst = rngSrc.Areas(2).Cells(zuviele + 1, 1)
End If
If Not rngDst Is Nothing Then Set FilterErsteZelle = rngDst
End If
End Function
Function FilterLetzteZelle(ueberschuss As Integer) As Integer
Dim rngSrc As Range, lastRow As Integer
If ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode Then
Set rngSrc = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
If rngSrc.Areas(1).Rows.Count > 1 Then
'Set rngDst = rngSrc.Areas(1).Cells(Cells(2, 6).End(xlDown).row, 6)
lastRow = Rows.Count
ElseIf rngSrc.Areas.Count > 1 Then
'Set rngDst = rngSrc.Areas(rngSrc.Areas.Count).Cells(Cells(1, 6).End(xlDown).row - ueberschuss, 6)
'Set rngDst = rngSrc.Areas(rngSrc.Areas.Count).Cells(1, 6)
lastRow = Range("A" & Rows.Count).End(xlUp).row
End If
If lastRow <> 0 Then FilterLetzteZelle = lastRow - ueberschuss
End If
End Function
letzte Relevante Methode:
Private Sub DisplayHelperTable(head As String)
Dim startCell As Range
Dim endCell As Range
Dim mergedCells As Range
Sheets("HelperTable").Select
Set startCell = Range("A" & Rows.Count).End(xlUp)
If startCell.row <> 1 Then
' startCell.row = startCell.row + 1
Set startCell = Cells(startCell.row + 1, startCell.Column)
End If
ActiveSheet.Cells(startCell.row, startCell.Column).Select
ActiveSheet.Paste
Set endCell = Range("F" & Rows.Count).End(xlUp)
Set mergedCells = Range(Cells(startCell.row, startCell.Column), endCell)
Call Create_SelfChart(mergedCells, startCell.row, head)
Set startCell = Nothing
Set endCell = Nothing
Set mergedCells = Nothing
End Sub
Vielen Danke schonmal für eure Hilfe.
Lg chris2589
|