Microsoft Excel

Herbers Excel/VBA-Archiv

Makro-Optimierung

Betrifft: Makro-Optimierung
von: Nicole
Geschrieben am: 22.04.2003 - 15:40:31

Hallo Ihrs,

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


  

Re: Makro-Optimierung
von: moe
Geschrieben am: 22.04.2003 - 16:08:24

Hallo Nicole

Du kannst alle do Loop anweisungen in einem loop durchlaufen lassen statt der activecell solltest du denn range nutzen .

Gruss

moe

Wollte ihn umschreiben war aber zu Faul wenn du es nicht hin kriegst meld dich dann mach ich es

  

Re: Makro-Optimierung
von: Nicole
Geschrieben am: 22.04.2003 - 16:13:25

hey moe,

mmhh.. bin noch nicht so ein VBA-Profi, so dass ich aus deinen Anweisungen nicht ganz schläu werde. Wäre echt toll, wenn du mir den Code umschreiben würdest oder zumindest, wenn du die Anfänge des Codes mit anschließendem ... schreiben würdest.
Danke für deine Mühe.
Nicole

  

Re: Makro-Optimierung
von: moe
Geschrieben am: 22.04.2003 - 16:14:52

Ich hoffe du brauchst das Ding nicht gleich aber später kann ich dir das machen dann hast du es morgen

Ist das OK

Gruss

Moe

  

Re: Makro-Optimierung
von: Nicole
Geschrieben am: 22.04.2003 - 16:18:28

ja, super, muß auch gleich weg.
danke, danke, danke im voraus für deine Mühe.
Nicole

  

Re: Makro-Optimierung
von: moe
Geschrieben am: 22.04.2003 - 16:22:10

Der Ideal fall wäre wenn du mir die Datei zuschicken würdest .

Gruss

moe

  

Re: Makro-Optimierung
von: Nicole
Geschrieben am: 22.04.2003 - 18:40:16

hey moe,

ich hoffe, du liest es noch.
kann dir die Datei leider nicht schicken, geht es auch so??
evtl. geht es ja auch nur mit kleinen Anfangshilfen, so in der Art: CODE ...
evtl. steig ich ja da durch und du ersparst dir die Tipparbeit.
Danke schonmal
Nicole

  

Re: Makro-Optimierung
von: moe
Geschrieben am: 23.04.2003 - 02:43:28

Hallo Nicole

ich konnte es leider nicht testen wenn aber funktioniert
sollte es dir eineige zeit sparen.

weil du mehrere Schleifen hattest aus der ich nur eine mache.
Es sind bestimmt noch kleiner Fehler drin da du mir Leider die Datei nicht zu schicken konntest .
Also Versuch es mal damit wenn es nicht klappt oder du nicht mehr weiter kommst melde dich und schick mir die datei zu.


Gruss

MOe

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
With Range("A5:J50")
.ClearContents
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = 15
End With
Range("A5").Select
Sheets("Auftragseingabe").Activate
Range("G1").Activate

iAnz = 0
i = 0

'Selektieren der Daten für Hammer aus allen Projekten
Do Until i = ActiveSheet.UsedRange.Rows.Count
Sheets("Auftragseingabe").Activate
Range("G1").Activate
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

Range("G1").Activate
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).Activate
End If

Range("G1").Select
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

Range("G1").Select
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

  

Re: Makro-Optimierung
von: moe
Geschrieben am: 23.04.2003 - 16:47:44

Wäre nett wenn du Feedbacl geben würdest

Gruss

moe