Select
09.07.2018 10:56:48
Gregor
Untenstehendes Makro funktioniert auf meinem PC ohne Fehlermeldung. Sobald dieses Makro von einem Mitarbeiter auf einem anderen PC ausgeführt wird, erfolgt eine erste Fehlermeldung 'Laufzeitfehler 1004' beim Abschnitt Hinfahrt beim Range-Befehl, weitere bei jedem Range-Befehl. Ich kann das lösen, wenn ich vor jedem Range-Befehl den Befehl select einfüge (siehe zweites Makro). Gibt es dafür eine Erklärung, eigentlich sollte der select-Befehl ja unnötig sein und vermieden werden.
Makro ohne select
Sub Übertragen()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim arrBlatt(20)
Dim lZeile_Copy
lastRow = Worksheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
arrBlatt(i - 1) = Worksheets("Master").Cells(i, "A")
Next i
For z = 1 To lastRow - 1
If WorksheetExists("DC " & arrBlatt(z)) Then
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "DC " & arrBlatt(z)
Worksheets("DC " & arrBlatt(z)).Select
ActiveWindow.Zoom = 80
MsgBox "Blatt DC " & arrBlatt(z) & " am Ende neu angelegt"
End If
Next
Blattname = Worksheets(1).Name
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
'Hinfahrt
.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
.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:
'Rückfahrt
lZeile = .Cells(Rows.Count, 1).End(xlUp).Row
Spalte = 0
Zähler = 1
lZeile_Copy = Worksheets("DC " & arrBlatt(y)).Cells(Rows.Count, 1).End(xlUp).Row
.Range(Cells(Zeile_Rück, 1), Cells(lZeile, 1)).Copy Worksheets("DC " & arrBlatt(y)). _
Cells(lZeile_Copy + 6, Zähler)
For Start = 1 To lSpalte
Spalte_Copy = Application.Match(arrBlatt(y), .Range(.Cells(Zeile_Rück, Start), . _
Cells(Zeile_Rück, lSpalte)), 0)
If IsError(Spalte_Copy) Then GoTo weiter1
Start = Start + Spalte_Copy - 1
Spalte = Spalte + Spalte_Copy
Zähler = Zähler + 1
.Range(Cells(Zeile_Rück, Spalte), Cells(lZeile, Spalte)).Copy
With Sheets("DC " & arrBlatt(y))
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteFormats
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteValues
End With
Next Start
weiter1:
Next y
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub Übertragen()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim arrBlatt(20)
Dim lZeile_Copy
lastRow = Worksheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
arrBlatt(i - 1) = Worksheets("Master").Cells(i, "A")
Next i
For z = 1 To lastRow - 1
If WorksheetExists("DC " & arrBlatt(z)) Then
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "DC " & arrBlatt(z)
Worksheets("DC " & arrBlatt(z)).Select
ActiveWindow.Zoom = 80
MsgBox "Blatt DC " & arrBlatt(z) & " am Ende neu angelegt"
End If
Next
Blattname = Worksheets(1).Name
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
'Hinfahrt
.Select
.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
.Select
.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:
'Rückfahrt
lZeile = .Cells(Rows.Count, 1).End(xlUp).Row
Spalte = 0
Zähler = 1
lZeile_Copy = Worksheets("DC " & arrBlatt(y)).Cells(Rows.Count, 1).End(xlUp).Row
.Select
.Range(Cells(Zeile_Rück, 1), Cells(lZeile, 1)).Copy Worksheets("DC " & arrBlatt(y)). _
Cells(lZeile_Copy + 6, Zähler)
For Start = 1 To lSpalte
Spalte_Copy = Application.Match(arrBlatt(y), .Range(.Cells(Zeile_Rück, Start), . _
Cells(Zeile_Rück, lSpalte)), 0)
If IsError(Spalte_Copy) Then GoTo weiter1
Start = Start + Spalte_Copy - 1
Spalte = Spalte + Spalte_Copy
Zähler = Zähler + 1
.Select
.Range(Cells(Zeile_Rück, Spalte), Cells(lZeile, Spalte)).Copy
With Sheets("DC " & arrBlatt(y))
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteFormats
.Cells(lZeile_Copy + 6, Zähler).PasteSpecial Paste:=xlPasteValues
End With
Next Start
weiter1:
Next y
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Vielen Dank und Gruss
Gregor