Dieser Code mit copypaste läuft sehr langsam:
Blattname = Worksheets(1).Name
lastRow = Worksheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(Blattname)
.Select
lSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Zeile_Hin = Application.Match("DC Hinfahrt", .Columns(1), 0)
Zeile_Rück = Application.Match("DC Rückfahrt", .Columns(1), 0)
For y = 1 To lastRow - 1
lZeile = .Cells(Cells(Zeile_Rück, 1).End(xlUp).Row + 1, 1).Row
Spalte = 0
Zähler = 1
With Worksheets("DC " & arrBlatt(y)).Rows.EntireRow
.ClearContents 'löscht die Inhalte, bzw. Formeln
.ClearFormats 'löscht die Formate
End With
Worksheets(Blattname).Range(Cells(Zeile_Hin, 1), Cells(lZeile, 1)).Copy Worksheets("DC " & arrBlatt(y)).Cells(1, Zähler)
For Start = 1 To lSpalte
Spalte_Copy = Application.Match(arrBlatt(y), .Range(.Cells(Zeile_Hin, Start), .Cells(Zeile_Hin, lSpalte)), 0)
If IsError(Spalte_Copy) Then GoTo weiter
Start = Start + Spalte_Copy - 1
Spalte = Spalte + Spalte_Copy
Zähler = Zähler + 1
Worksheets(sTxt).Range(Cells(Zeile_Hin, Spalte), Cells(lZeile - 1, Spalte)).Copy
With Sheets("DC " & arrBlatt(y))
.Cells(1, Zähler).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, Zähler).PasteSpecial Paste:=xlPasteFormats
.Cells(1, Zähler).PasteSpecial Paste:=xlPasteValues
End With
Next Start
weiter:
Statt mit copypaste versuche ich es mit folgendem Array, der Array bleibt jedoch leer. Wie kann ich diese füllen und zurückschreiben?
Beispiel
Sub meinArray()
Dim myArr(1 To 44, 1 To 7) As Variant
Dim myRow As Long
Dim myCol As Integer
Blattname = Worksheets(1).Name
myRow = 1 'Startzeile
myCol = 1 'Startspalte
'Array füllen
For Start = 1 To 7
myArr(1, Start) = Sheets(Blattname).Range(Cells(9, Start), Cells(52, Start)) 'Array fü _
llen
Next
'Array zurückschreiben
With Sheets("DC 1132")
.Range(.Cells(myRow, myCol), _
.Cells(myRow + UBound(myArr, 1) - 1, myCol + UBound(myArr, 2) - 1)) = myArr()
End With
End Sub
Danke und Gruss
Gregor