Noch ein Beispiel (das bei mir funktioniert)
Moings,
ich glaube, der Reinhard hatte versehentlich die falschen Zellen miteinander verbunden. Wenn nicht, dann mache ICH das eben in meinem Beispiel 
Siehe unten:
Sub Sortierer()
Const dx As Integer = 0 'Spalten-Offset (falls die Zielspalte nicht x1, sondern x1+dx ist)
Const dy As Integer = 0 'Zeilen-Offset (falls die Zielzeile nicht y1, sondern y1+dy ist)
Const yM As Integer = 3 'Anzahl der zu verbindenden Zeilen
Dim x1 As Integer 'Nummer der ersten Spalte
Dim x2 As Integer 'Nummer der letzten Spalte
Dim y1 As Integer 'Nummer der ersten Zeile
Dim y2 As Integer 'Nummer der letzten Zeile
Dim x As Integer
Dim y As Integer
Dim R As Range
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Set wsQ = Worksheets("Werkzeug")
Set wsZ = Worksheets("Verleih")
wsQ.Activate '"Selection" bezieht sich dann auf dieses Blatt
x1 = Selection.Column
y1 = Selection.Row
If Selection.Count = 1 Then
'Es wurde nur die oberste linke Zelle des zu kopierenden Bereichs ausgewählt.
x2 = wsQ.Cells(y1, 256).End(xlToLeft).Column 'Von der letzten Spalte aus wird nach links nach
'der nächsten "vollen" Zelle in Zeile y1 gesucht.
y2 = wsQ.Cells(65536, x1).End(xlUp).Row 'Von der letzten Zeile aus wird aufwärts nach
'der nächsten "vollen" Zelle in Spalte x1 gesucht.
Range(Cells(y1, x1), Cells(y2, x2)).Select
Else 'Selection.Count = 1
'Es wurde schon der gesamte zu kopierende Bereich ausgewählt.
x2 = Selection.Columns.Count + x1 - 1
y2 = Selection.Rows.Count + y1 - 1
End If 'Selection.Count = 1
For y = y1 To y2
wsQ.Activate 'man kann dummerweise nicht von einem deaktivierten Blatt aus kopieren
wsQ.Range(Cells(y, x1), Cells(y, x2)).Copy Destination:=wsZ.Cells(yM \* (y - y1) + y1 + dy, x1 + dx)
wsZ.Activate
For x = x1 To x2
wsZ.Range(Cells(yM \* (y - y1) + y1 + dy, x + dx), \_
Cells(yM \* (y - y1) + y1 + yM - 1 + dy, x + dx)).MergeCells = True
Next x
Next y
Set wsQ = Nothing 'Freigeben des Worksheet-Objekts (nicht nötig, aber guter Stil)
Set wsZ = Nothing 'dito
End Sub 'Sortierer
Und hier nochmal zum Copy/Paste (alle ° durch Leerzeichen ersetzen danach):
Sub Sortierer()
Const dx As Integer = 0 'Spalten-Offset (falls die Zielspalte nicht x1, sondern x1+dx ist)
Const dy As Integer = 0 'Zeilen-Offset (falls die Zielzeile nicht y1, sondern y1+dy ist)
Const yM As Integer = 3 'Anzahl der zu verbindenden Zeilen
Dim x1 As Integer 'Nummer der ersten Spalte
Dim x2 As Integer 'Nummer der letzten Spalte
Dim y1 As Integer 'Nummer der ersten Zeile
Dim y2 As Integer 'Nummer der letzten Zeile
Dim x As Integer
Dim y As Integer
Dim R As Range
Dim wsQ As Worksheet
Dim wsZ As Worksheet
°°°°Set wsQ = Worksheets(„Werkzeug“)
°°°°Set wsZ = Worksheets(„Verleih“)
°°°°wsQ.Activate '„Selection“ bezieht sich dann auf dieses Blatt
°°°°x1 = Selection.Column
°°°°y1 = Selection.Row
°°°°If Selection.Count = 1 Then
°°°°°°°’Es wurde nur die oberste linke Zelle des zu kopierenden Bereichs ausgewählt.
°°°°°°°°x2 = wsQ.Cells(y1, 256).End(xlToLeft).Column 'Von der letzten Spalte aus wird nach links nach
°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°’der nächsten „vollen“ Zelle in Zeile y1 gesucht.
°°°°°°°°y2 = wsQ.Cells(65536, x1).End(xlUp).Row°°°°°°’Von der letzten Zeile aus wird aufwärts nach
°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°’der nächsten „vollen“ Zelle in Spalte x1 gesucht.
°°°°°°°°Range(Cells(y1, x1), Cells(y2, x2)).Select
°°°°Else 'Selection.Count = 1
°°°°°°°’Es wurde schon der gesamte zu kopierende Bereich ausgewählt.
°°°°°°°°x2 = Selection.Columns.Count + x1 - 1
°°°°°°°°y2 = Selection.Rows.Count + y1 - 1
°°°°End If 'Selection.Count = 1
°°°°For y = y1 To y2
°°°°°°°°wsQ.Activate 'man kann dummerweise nicht von einem deaktivierten Blatt aus kopieren
°°°°°°°°wsQ.Range(Cells(y, x1), Cells(y, x2)).Copy Destination:=wsZ.Cells(yM * (y - y1) + y1 + dy, x1 + dx)
°°°°°°°°
°°°°°°°°wsZ.Activate
°°°°°°°°For x = x1 To x2
°°°°°°°°°°°°wsZ.Range(Cells(yM * (y - y1) + y1 + dy, x + dx), _
°°°°°°°°°°°°°°°°°°°°°°Cells(yM * (y - y1) + y1 + yM - 1 + dy, x + dx)).MergeCells = True
°°°°°°°°Next x
°°°°Next y
°°°°Set wsQ = Nothing 'Freigeben des Worksheet-Objekts (nicht nötig, aber guter Stil)
°°°°Set wsZ = Nothing 'dito
End Sub 'Sortierer
Die zweite Variante habe ist der gleiche Text, aber zumindest ICH kann die mit „PRE“ formatierten Texte nicht ordentlich kopieren, da alle Zeilenumbrüche dabei verschwinden.
Kristian