AW: Daten auf Blätter verteilen
14.07.2008 13:48:12
Erich
Hi Joachim,
dann muss es (bei so langen Texten) eben doch Copy - PasteSpecial sein.
Gestört haben dabei die verbundenen Zellen, damit verbunden dann auch die Zeilenhöhe.
So sollte es klappen:
Option Explicit
' Zieladresse 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)
ReDim strM(1 To lngC)
ReDim 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
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
Next zz
Application.CutCopyMode = False
End With
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort