Option Explicit
' Zieladresse im Muster ist rechts neben der Zelle,
' die die Überschrift & " :" enthält.
Sub transp()
Dim lngC As Long, rng As Range, ii As Long, zz As Long, strAd() As String
Dim strM() As String, dblH() As Double
lngC = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim strAd(1 To lngC), strM(1 To lngC), dblH(1 To lngC)
With Worksheets("Muster")
For ii = 1 To lngC
Set rng = .Cells.Find(Cells(1, ii) & " :")
If rng Is Nothing Then
MsgBox "Text '" & Cells(1, ii) & "' im Muster nicht gefunden"
Else
strAd(ii) = rng.Offset(, 1).Address ' Zieladressen merken
If .Range(strAd(ii)).MergeArea.Address strAd(ii) Then
strM(ii) = .Range(strAd(ii)).MergeArea.Address ' Merge merken
dblH(ii) = .Range(strAd(ii)).RowHeight ' Höhe merken
End If
End If
Next ii
End With
With ActiveSheet
For zz = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not .Rows(zz).Hidden Then 'neu 07.08.2008
Worksheets("Muster").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Vorgang" & Format(zz - 1, " 00")
For ii = 1 To lngC
If strAd(ii) > "" Then
If strM(ii) > "" Then Range(strM(ii)).UnMerge
.Cells(zz, ii).Copy
Range(strAd(ii)).PasteSpecial xlPasteValues
If strM(ii) > "" Then
Range(strM(ii)).Merge
Range(strAd(ii)).RowHeight = dblH(ii)
End If
End If
Next ii
End If 'neu 07.08.2008
Next zz
Application.CutCopyMode = False
End With
End Sub
Und hier eine Spielmappe: https://www.herber.de/bbs/user/54428.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort