Erste Ebene einer Gliderung mit VBA ansprechen
26.07.2013 12:12:16
Janga
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
**************************************