Thema Datum  Von Nutzer Rating
Antwort
Rot bestimmte Range aus Zellenbereich kopieren
 24.07.2014 10:49:46 chris2589
Solved
24.07.2014 14:27:20 chris2589
Solved
24.07.2014 19:22:58 Gast84811
NotSolved

Ansicht des Beitrags:
Von:
chris2589		 Datum:
24.07.2014 10:49:46		 Views:
1899		 Rating:
     
Antwort:
 Nein
Thema:
bestimmte Range aus Zellenbereich kopieren

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:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
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:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
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:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
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

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot bestimmte Range aus Zellenbereich kopieren
 24.07.2014 10:49:46 chris2589
Solved
24.07.2014 14:27:20 chris2589
Solved
24.07.2014 19:22:58 Gast84811
NotSolved