Spalten gruppieren

Hallo liebe Leser,
ich habe folgendes Anliegen:
Ich möchte gerne in einer Datei Spalten gruppieren.
Grundlage ist Zelle C6. Dort steht die KW, die ausgewählt wurde.
Ab Zelle AJ7 stehen die KWs den Spalten entlang mit den jeweiligen Werten darunter.
Nun soll geschaut werden, in welcher Zelle (AJ7, AJ8,...) der Wert Hintergrund ist, dass sich ein Diagramm darauf bezieht. In diesem sollen nur so viele Balken angezeigt werden, wie die KW ausgewählt wurde (KW = 6 --> 6 Balken).
Ich habe bereits begonnen zu programmieren, komme aber gerade nicht weiter:


Sub Spalten_ausblenden()
' Spalten_ausblenden Makro
' variabel mit ausgewählter Woche Spalten ausblenden für Diagramm Stunden im Zeitverlauf
Dim i As Integer
Dim j As Integer
Dim k As Integer
j = 36 'Zähler soll nach rechts gehen (die Spalten entlang), 36=Spalte AJ
k = 7 'Zeile 7
i = ActiveSheet.Range("c6").Value 'i = Zellinhalt C6, d.h. KW, nach der gruppiert werden soll (KW +1)
ActiveSheet.Cells(k, j).Select
If Cells(k, j).Value 
>

Ich habe die Vermutung, dass das Problem bei dem ersten "Columns("j:j").Select" besteht, denn dort hakt es.

Ggf. wäre es besser mit J=J+1 aber ich weiß nicht, wo ich es einbinden soll.

Kann mir jemand helfen?

Lieben Dank und 

liebe Grüße,

Sabi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Spalten_ausblenden() Dim Sp As Integer 'ActiveSheet ist immer default 'alles ungruppieren For Sp = 36 To 92 Columns(Sp & ":" & Sp).Ungroup Next 'Finden, wo die Bedingung nicht mehr triff Sp = 36 Do While Cells(7, Sp).Value

Sub Spalten_ausblenden() Dim Sp As Long Const SP_anf = 36 Const SP_end = 92 'ActiveSheet ist immer default, es sei denn, der Code ist in dem Codefenster eines Blattes. Dann ist immer dieses Blatt per Default gemeint 'Alles ungruppieren, fehlertolerant On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup On Error GoTo 0 'Nicht mehr fehlertolerant 'Finden, wo die Bedingung nicht mehr triff Sp = SP_anf Do While Cells(7, Sp).Value

Sub Spalten_ausblenden() Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 'ActiveSheet ist immer default, es sei denn, der Code ist in dem Codefenster eines Blattes. Dann ist immer dieses Blatt per Default gemeint 'Alles ungruppieren, fehlertolerant On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup On Error GoTo 0 'Nicht mehr fehlertolerant 'Finden, wo die Bedingung nicht mehr triff Sp = SP_anf Do Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Group Loop While Cells(7, Sp).Value > Range("C6").Value And Sp

Sub Spalten_ausblenden() Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 'ActiveSheet ist immer default, es sei denn, der Code ist in dem Codefenster eines Blattes. Dann ist immer dieses Blatt per Default gemeint 'Alles ungruppieren, fehlertolerant On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup On Error GoTo 0 'Nicht mehr fehlertolerant 'Finden, wo die Bedingung noch zutriff Sp = SP_end Do Until Cells(7, Sp).Value = Range("C6").Value And Sp > SP_anf Sp = Sp - 1 Loop Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Intersect(Target, Range("$C$6")) Is Nothing Then Exit Sub Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 'ActiveSheet ist immer default, es sei denn, der Code ist in dem Codefenster eines Blattes. Dann ist immer dieses Blatt per Default gemeint 'Alles ungruppieren, fehlertolerant On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup On Error GoTo 0 'Nicht mehr fehlertolerant 'Finden, wo die Bedingung noch zutriff Sp = SP_end Do Until Cells(7, Sp).Value = Range("C6").Value And Sp > SP_anf Sp = Sp - 1 Loop Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 ActiveSheet.Outline.ShowLevels RowLevels:=1 End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static Memory As String Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 If Target.Cells.Count > 1 Then GoTo Memory_Save If Intersect(Target, Range(Memory)) Is Nothing Then GoTo Memory_Save 'Alles ungruppieren, fehlertolerant On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup Application.EnableEvents = False 'Finden, wo die Bedingung noch zutriff Sp = Range("AK7:CK7").Find(What:=Range("C6")).Column If Sp > 0 Then Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group 'Gruppierung zuklappen ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 ActiveSheet.Outline.ShowLevels RowLevels:=1 GoTo Memory_Save: Memory = Target.Range("A1").Address '"A1" ist der relative bezug, falls Target mehr als eine Zelle hat Application.EnableEvents = True End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static Memory As String Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter If Target.Cells.Count > 1 Then GoTo Memory_Save If Intersect(Target, Range(Memory)) Is Nothing Then GoTo Memory_Save 'Alles ungruppieren, fehlertolerant Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup Application.EnableEvents = False 'Finden, wo die Bedingung noch zutriff Sp = Range("AK7:CK7").Find(What:=Range("C6")).Column If Sp > 0 Then Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group 'Gruppierung zuklappen ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 ActiveSheet.Outline.ShowLevels RowLevels:=1 Memory_Save: Memory = Target.Address Application.EnableEvents = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Sp As Long Const SP_anf = 37 Const SP_end = 92 On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter If Target.Address "$C$6" Then Exit Sub 'Alles ungruppieren, fehlertolerant Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup Application.EnableEvents = False 'Finden, wo die Bedingung noch zutriff Sp = Range("AK7:CK7").Find(What:=Range("C6")).Column If Sp > 0 Then Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group 'Gruppierung zuklappen ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 ActiveSheet.Outline.ShowLevels RowLevels:=1 Application.EnableEvents = True End Sub

Guten Morgen Yal,
die Erklärung


"In C6 muss eine Wert eingetragen werden, keine Formel. Auf Änderung der Ergebnis eine Formel (die selbst sich nicht ändert) reagiert das Ereignis-Prozedure nicht. Dann muss Du suchen, in welcher Zelle eine Eingabe gemacht wird, die zu einem neuen Ergebnis in der Zelle C6 führt."

hat sehr geholfen!
In der Zelle C7, also darunter, ist ein Dropdown (variabel), in dem man die KW auswählen kann.
Von da aus zieht es sich dann in Zelle C6, d.h. in Zelle C6 steht (wenn(in Zelle C7 was steht; nimm Zelle C7; sonst die vergangene Woche).
Wenn ich bei der Dropdown was auswähle, rechnet sich nun das Makro. Super.
Wenn ich die Zahl aus Zelle C7 lösche, also entf drücke, dann allerdings nicht, Das verstehe ich noch nicht ganz...*Schulter zuck*
Mein Code sieht jetzt so aus:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("$C$7")) Is Nothing Then Exit Sub
Dim Sp As Long
Const SP_anf = 37
Const SP_end = 92
'ActiveSheet ist immer default, es sei denn, der Code ist in dem Codefenster eines Blattes. Dann ist immer dieses Blatt per Default gemeint
'Alles ungruppieren, fehlertolerant
On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter
Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup
On Error GoTo 0 'Nicht mehr fehlertolerant
'Finden, wo die Bedingung noch zutriff
Sp = SP_end
Do Until Cells(7, Sp).Value = Range("C6").Value And Sp > SP_anf
Sp = Sp - 1
Loop
Range(Cells(1, Sp + 1), Cells(1, SP_end)).EntireColumn.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
ActiveSheet.Outline.ShowLevels RowLevels:=1
End Sub
und funktioniert soweit auch. Super. Nur eben wenn ich die Zahl lösche aus C7 tut sich nichts. dann muss ich das Makro manuell starten.
LG
Sabi

Sub Spalten_ausblenden() Dim Sp As Long Const SP_anf = 37 Const SP_end = 89 On Error Resume Next 'Ignoriere den Fehler und mache einfach weiter Range(Cells(1, SP_anf), Cells(1, SP_end)).EntireColumn.Ungroup 'Finden, wo die Bedingung noch zutriff Sp = Range("AK7:CK7").Find(What:=Range("C6")).Column 'Achtung verursacht ev. auch ein Fehler. Den "On Error Goto 0" habe ich rausgenommen If Sp >= Sp_anf Then Range(Cells(1, Sp), Cells(1, SP_end)).EntireColumn.Group End Sub

Beliebteste Forumthreads (12 Monate)

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread