Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
244to248
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
244to248
244to248
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro-Optimierung

Makro-Optimierung
22.04.2003 15:40:31
Nicole
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


8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Makro-Optimierung
22.04.2003 16:08:24
moe

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
22.04.2003 16:13:25
Nicole

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
22.04.2003 16:14:52
moe

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

Anzeige
Re: Makro-Optimierung
22.04.2003 16:18:28
Nicole

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

Re: Makro-Optimierung
22.04.2003 16:22:10
moe

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

Gruss

moe

Re: Makro-Optimierung
22.04.2003 18:40:16
Nicole

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
23.04.2003 02:43:28
moe

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

Anzeige
Re: Makro-Optimierung
23.04.2003 16:47:44
moe

Wäre nett wenn du Feedbacl geben würdest

Gruss

moe

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige