da dieses Makro in ähnlicher Form ca. 20x in einer Datei beim Schließen ausgeführt wird, was sehr lange dauert, wäre es echt toll, wenn ihr mir helfen könntet, den Code zu optimieren:
Sub Hammer()
Const Auftragseingabe = "Quelle"
Const Hammer = "Ziel"
Dim i As Integer
Dim iAnz As Integer
Dim Bezeichnung As Name
Dim z As Integer
Application.ScreenUpdating = False
'Löschen aller Daten in der Tabelle
Range("A5:J50").Select
ActiveWindow.SmallScroll Down:=-12
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Interior.ColorIndex = 15
Range("A5").Select
Sheets("Auftragseingabe").Activate
Range("G1").Select
iAnz = 0
i = 0
'Selektieren der Daten für Hammer aus allen Projekten
Do Until i = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = Sheets("Grunddaten").Cells(28, 2).Value Then
z = ActiveCell.Row
Range("A" & z, "J" & z).copy
Sheets("Hammer").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
ActiveCell.Offset(1, 0).Select
Sheets("Auftragseingabe").Select
ActiveCell.Offset(1#).Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Loop
Range("G1").Select
iAnz = 0
i = 0
Do Until i = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = Sheets("Grunddaten").Cells(29, 2).Value Then
z = ActiveCell.Row
Range("A" & z, "J" & z).copy
Sheets("Hammer").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
ActiveCell.Offset(1, 0).Select
Sheets("Auftragseingabe").Select
ActiveCell.Offset(1#).Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Loop
Range("G1").Select
iAnz = 0
i = 0
Do Until i = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = Sheets("Grunddaten").Cells(30, 2).Value Then
z = ActiveCell.Row
Range("A" & z, "J" & z).copy
Sheets("Hammer").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
ActiveCell.Offset(1, 0).Select
Sheets("Auftragseingabe").Select
ActiveCell.Offset(1#).Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Loop
Range("G1").Select
iAnz = 0
i = 0
Do Until i = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = Sheets("Grunddaten").Cells(31, 2).Value Then
z = ActiveCell.Row
Range("A" & z, "J" & z).copy
Sheets("Hammer").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
ActiveCell.Offset(1, 0).Select
Sheets("Auftragseingabe").Select
ActiveCell.Offset(1#).Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Loop
Sheets("Hammer").Activate
Range("A5").Select
' Sortierung
Range("A5:J50").Select
Selection.sort Key1:=Range("A5"), Order1:=xlAscending, Key2:=Range("B5") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
Range("A5").Select
' Aufhebung der Gültigkeitsprüfung
Cells.Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
'Alle Zellen sperren
Cells.Locked = True
Selection.FormulaHidden = False
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Danke für die Hilfe.
Nicole