AW: Bereich Kopieren x mal
31.08.2008 16:38:26
Erich
Hi Karel,
probier mal
Option Explicit
Sub test()
Dim rngVor As Range, lngZ As Long, lngS As Long, rngR As Range, ii As Long
With Sheets("Tabelle2")
Set rngVor = .Range("A1:E6")
lngS = rngVor.Columns.Count
lngZ = rngVor.Rows.Count * .Range("G3").Value
End With
With Sheets("Tabelle3").Range("A1").Resize(lngZ, lngS)
.EntireColumn.Clear ' löschen
rngVor.Copy Destination:=.Cells ' kopieren
.Formula = .Value ' Formeln in Werte
For ii = 1 To lngS ' Spaltenbreiten
.Columns(ii).ColumnWidth = rngVor.Columns(ii).ColumnWidth
Next ii
For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen
Set rngR = .Rows(lngZ)
For ii = 1 To Sheets("Tabelle2").Range("G3").Value - 1
Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count))
Next ii
rngR.RowHeight = rngVor.Rows(lngZ).RowHeight
Next lngZ
End With
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort