Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1324to1328
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Erste Ebene einer Gliderung mit VBA ansprechen

Erste Ebene einer Gliderung mit VBA ansprechen
26.07.2013 12:12:16
Janga
Hallo zusammen
Mein Problem betrifft eine umfangreiche Referenzliste:
diese ist aufgeteilt in 26 Tabellenblätter (jeweils ein Land pro Blatt)gleichen Aufbaus.
Die Daten aller Blätter werden auf einer Übersichtsseite mittels Makro zusammengeführt.
Mein Problem ist, dass die Daten auf den einzelnen Blättern gegliedert sind (1. Ebene = wichtigste Eckdaten, 2. Ebene und weitere = Adresse, Infos etc.)und ich eigentlich nur die erste Ebene der Gliederung auf der Übersichtsseite benötige.
Gibt es einen Code, mit welchem man nur die 1. Ebene einer Gliederung ansprechen und wiedergeben kann?
Herzlichen Dank schon mal im Voraus für eure Hilfe!
Hier der Link zum Excel-File https://www.herber.de/bbs/user/86579.xlsm
Der bestehende Code sieht so aus:
**************************************
Dim wks As Worksheet 'Tabelle AlleDaten
Dim intSh As Integer 'Zähler für Tabelle1 bis TabelleX
Dim intLastS As Integer 'Letzte benutzte Spalte in den Tabellen
Dim lngCopyRows As Long 'Anzahl kopierte Zeilen
Dim bln As Boolean
'Prüfung ob Blatt "AlleDaten" bereits vorhanden ist.
For intSh = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(intSh).Name = "AlleDaten" Then
Set wks = Worksheets("AlleDaten")
bln = True
Exit For
End If
Next
'Falls nicht vorhanden dann erstellen
If bln = False Then
Set wks = Worksheets.Add
wks.Name = "AlleDaten"
End If
'Blatt AlleDaten nach links schieben
wks.Move Before:=Sheets(1)
'Daten auf Blatt "AlleDaten" löschen und die Überschrift aus Tabelle1 holen
'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss
wks.Cells.ClearContents
wks.Range("A1").Value = "Tabellenname"
Worksheets(2).Range("A1:IU1").Copy Destination:=wks.Range("B1")
intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column
'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen
For intSh = 2 To ActiveWorkbook.Worksheets.Count
With Worksheets(intSh)
.Range(.Cells(2, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).Copy
wks.Cells(wks.UsedRange.Rows.Count, 2).Offset(1, 0).PasteSpecial Paste:=xlValues
lngCopyRows = wks.UsedRange.Rows.Count - Cells(Rows.Count, 1).End(xlUp).Row
wks.Range("A" & wks.Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lngCopyRows) = Worksheets(intSh).Name
End With
Next
Application.CutCopyMode = False
MsgBox "Die Daten aus " & intSh - 2 & " Tabellenblättern wurden gelistet.", 64
End Sub
Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long
Dim intS As Integer
With Worksheets(intSh)
For intS = 1 To intLastS
If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then
fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row
End If
Next
End With
End Function

**************************************

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Nur Gliederungsebene 1 : 2 Zeilen Codeanpassung
26.07.2013 12:52:44
NoNet
Hallo Janga,
das lässt sich einfach mit 2 Zeile VBA-Code realisieren :
Kopiere diesen Teil in das Makro "AlleDaten2" an die entsprechende Stelle :
'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen
For intSh = 2 To ActiveWorkbook.Worksheets.Count
With Worksheets(intSh)
.Outline.ShowLevels RowLevels:=1 'Gliederung Ebene1
.Range(.Cells(2, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).SpecialCells(xlCellTypeVisible).Copy
wks.Cells(wks.UsedRange.Rows.Count, 2).Offset(1, 0).PasteSpecial Paste:=xlValues
lngCopyRows = wks.UsedRange.Rows.Count - Cells(Rows.Count, 1).End(xlUp).Row
wks.Range("A" & wks.Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lngCopyRows) = Worksheets(intSh).Name
End With
Next
Die rotmarkierten Codestellen habe ich einfgefügt - mehr nicht !
Gruß, NoNet
Hast Du Interesse, andere Excel-Begeisterte kennenzulernen ? - Dann komme zum
Exceltreffen 11.-13.10.2013 in Duisburg

http://www.exceltreffen.de/index.php?page=230
Anmeldungen sind noch bis 31.07.2013 möglich ! - Schau doch mal rein !

Anzeige
AW: Nur Gliederungsebene 1 : 2 Zeilen Codeanpassung
26.07.2013 14:05:45
Janga
Hi NoNet
Ganz herzlichen Dank für deine schnelle Hilfe! Mein Weekend ist gerettet :o)
Gruss, Janga

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige