AW: Spalte kopieren
23.05.2013 20:24:05
fcs
Hallo Chris,
geht etwa so.
Gruß
Franz
Sub Test()
Dim wks As Worksheet, lngSpalte As Long, lngZeile As Long, lngLast As Long
Dim StatusCalc As Long
Set wks = Worksheets("BASIS")
'Makrobremsem lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wks
'Daten kopieren
lngZeile = 16
For lngSpalte = 6 To 144 Step 6 'F bis EN
lngLast = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
If lngLast >= 16 Then
With .Range(.Cells(16, lngSpalte), .Cells(lngLast, lngSpalte))
.Copy Destination:=wks.Cells(lngZeile, 156)
lngZeile = lngZeile + .Rows.Count
End With
End If
Next
'Leere Zellen löschen in Zielspalte
If lngZeile > 16 Then
lngLast = .Cells(.Rows.Count, 156).End(xlUp).Row
On Error Resume Next
With .Range(.Cells(16, 156), .Cells(lngLast, 156))
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
End With
End If
End With
'Makrobremsem zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
Set wks = Nothing
End Sub