Hallo
obwohl ich schon lange Programmiere habe ich nicht allzuviel vom Vorgänger verstanden. Ist mir zu abstrakt.
Hier mal ein kleines Makro mit dem man die Aufgabe lösen kann wenn es weiter unten keine Überschriften mehr gibt. Ansonsten wird nur der 1. Block kopiert, für den nächsten Block muss man ein erweitertes makro schreiben.Den Block ab For sp = 1 to LSp kopieren und unten anfügen. Beim 2. Block muss For ze = 2 to LZe auf die Zeile des 2. Blockbereichs gesetzt werden. Würde micvh freuen wenn das makro weiterhilft.
mfg Noibody
Dim ZielAdr As String
Dim ZielAdr As String
Dim Ziel As Worksheet
Sub Überschriften_suchen()
Dim ze As Long, sp As Integer
Dim LZe As Long, LSp As Integer
With Worksheets("Tabelle1") 'Name der Starttabelle angeben
'LastSpalte und LastZell ermitteln
LSp = .Cells(1, Columns.Count).End(xlToLeft).Column
LZe = .Cells(Rows.Count, 1).End(xlUp).Row
'Name der Zieltabelle angeben
Set Ziel = Worksheets("Zieltabelle")
ZielAdr = "A1" '1. Zieladresse angeben
'1.Schleife sucht die Spalten Überschrift
For sp = 1 To LSp 'Spalte A bis xxx
If .Cells(1, sp).Font.Bold = True Then
'2.Schleife sucht die Endzeile bis zur unteren Überschrift
For ze = 2 To LZe 'Zeile 2 bis xxx
If .Cells(ze, sp).Font.Bold = True Then Exit For
Next ze
'sp ist die gefundene Spakte mit fetter Überschrift
'ze ist dieletzte Zeile bis unten eine Überschrift kommt
'diesen Bereich kannman in eine andere Tabelle kopieren
AnfAdr = .Cells(1, sp).Address
EndAdr = .Cells(ze, sp).Address
'gefundenen Bereich kopieren
.Range(AnfAdr, EndAdr).Copy
Ziel.Range(ZielAdr).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'nächste Zieladresse setzen
ZielAdr = Ziel.Range(ZielAdr).Offset(0, 1).Address
End If
Next sp
End With
End Sub
|