VBA - Gruppierungen dynamisch kopieren
05.08.2016 11:30:13
Tom
ich hab hier nen Problem, welches sich nicht so recht lösen lässt. Vlt. kann mir ein findiger Fuchs von Euch helfen.
Hab mir schon ein relativ langes (für meine Anfängerverhältnisse) Makro gebastelt, welches schon sehr dynamisch agiert. Allerdings hab ich noch ein zwei Feinheiten die behoben werden müssten.
Ich möchte gerne aus dem 1. Tabellenblatt meine gefilterten Daten samt Gruppierung ans Ende _ kopieren und dort als Werte einfügen. Soweit schaff ich das auch alles. Nun kam aber noch die Problematik der dynamischen Gruppierungen dazu. Ich hab bis jetzt nur einen festen Bereich eingetragen, der in dem neuen Blatt gruppiert wird. Hier der kurze Auszug aus dem gesamten Code.
'Gruppierung aus Ursprungsformat herstellen
Columns("F:G").Select
Selection.Columns.Group
Columns("V:AA").Select
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
Zum Verständnis die Datei:
https://www.herber.de/bbs/user/107414.xlsm
Bitte gebt mir kurz bescheid, wenn etwas unklar formuliert ist und die Frage so nicht beantwortet werden kann.
Gruß Lemms
Hier der ganze Code:
Sub Makro8()
'Gruppierung öffnen
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
'Kampagnenbericht außer Puffer-Kasten kopieren
ActiveCell.CurrentRegion.Select
Selection.Copy
'Gruppierung schließen
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
'Tabellenblatt am Ende erstellen und Daten einfügen
Sheets.Add After:=Sheets(Sheets.Count)
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Gruppierung aus Ursprungsformat herstellen
Columns("F:G").Select
Selection.Columns.Group
Columns("V:AA").Select
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
'Datums- und Pufferkasten kopieren
Sheets("Kampagnen-Bericht").Select
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
Range("A3:B14").Select
Selection.Copy
Sheets(Sheets.Count).Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
Else:
Range("A3:B14").Select
Selection.Copy
Sheets(Sheets.Count).Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
End If
'Tabellenblatt umbenennen
On Error GoTo Errorhandler
Dim TabName
TabName = Application.InputBox(Prompt:="Geben Sie einen Namen für das Tabellenblatt ein.", _
_
Type:=2, Default:="Blatt1")
If TabName = False Then
MsgBox "Eingabe wurde abgebrochen!"
ElseIf TabName = "" Then
MsgBox "Nix eingegeben!"
Else
ActiveSheet.Name = TabName
End If
'Zurück zum Tabellenblatt Kampagnen-Bericht
Sheets("Kampagnen-Bericht").Select
Range("D3").Select
Exit Sub
Errorhandler:
MsgBox "Eingabe nicht erlaubt"
End Sub