AW: Datenbloecke in Zeilen schreiben
27.10.2009 07:30:13
fcs
Hallo Volker,
hier 2 Varianten.
Gruß
Franz
Sub aaTest()
'Kopieren in 2. Blatt
Dim wksQ As Worksheet, ZeileQ As Long, ZeileQ1 As Long
Dim wksZ As Worksheet, ZeileZ As Long, SpalteZ As Long
Dim lCalc As Long
Const ZeilenBlock As Long = 5
Const SpaltenBlock As Long = 6
Set wksQ = Worksheets("Ausgangsdaten")
Set wksZ = Worksheets("Ergebnis")
ZeileZ = 0
With Application
.ScreenUpdating = False
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For ZeileQ = 1 To wksQ.Cells.SpecialCells(xlCellTypeLastCell).Row Step 5
ZeileZ = ZeileZ + 1
For ZeileQ1 = 0 To ZeilenBlock - 1
SpalteZ = 1 + ZeileQ1 * SpaltenBlock
With wksQ
.Range(.Cells(ZeileQ + ZeileQ1, 1), .Cells(ZeileQ + ZeileQ1, SpaltenBlock)).Copy _
Destination:=wksZ.Cells(ZeileZ, SpalteZ)
End With
Next
Next
With Application
.ScreenUpdating = True
.Calculation = lCalc
.EnableEvents = True
End With
End Sub
Sub bbTest()
'Umgruppieren im gleichen Blatt
Dim wksQ As Worksheet, ZeileQ As Long, ZeileQ1 As Long
Dim wksZ As Worksheet, ZeileZ As Long, SpalteZ As Long
Dim lCalc As Long
Const ZeilenBlock As Long = 5
Const SpaltenBlock As Long = 6
Set wksQ = ActiveSheet
Set wksZ = ActiveSheet
ZeileZ = 0
With Application
.ScreenUpdating = False
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For ZeileQ = 1 To wksQ.Cells.SpecialCells(xlCellTypeLastCell).Row Step 5
ZeileZ = ZeileZ + 1
For ZeileQ1 = 0 To ZeilenBlock - 1
SpalteZ = 1 + ZeileQ1 * SpaltenBlock
With wksQ
.Range(.Cells(ZeileQ + ZeileQ1, 1), .Cells(ZeileQ + ZeileQ1, SpaltenBlock)).Cut _
Destination:=wksZ.Cells(ZeileZ, SpalteZ)
End With
Next
Next
With Application
.ScreenUpdating = True
.Calculation = lCalc
.EnableEvents = True
End With
End Sub