Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1008to1012
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
Inhaltsverzeichnis

Prozedur scheller machen?

Prozedur scheller machen?
23.09.2008 19:57:09
Lemmi
Hallo zusammen,
ich habe mitleer weile einige Private Sub Worksheet_Activate()
in einem Arbeitsblatt untergebracht und habe nun ein kleines zeitliches Problem bekommen!
Die Eingaben und Aktionen werden schon sehr verzögert!
Kann mann das noch durch andere Prozeduren schneller bekommen!
Gruß
Lemmi

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Prozedur scheller machen?
23.09.2008 20:00:32
Hajo_Zi
Hallo Lemmi,
wir sehen Deinen Code nicht.
Excel ist ein vielseitiges Programm und man kann viele Probleme damit lösen. Jede positive Seite hat aber auch negative Aspekte - einer davon ist im Makrorecorder enthalten.
Die Bücher, die es zu Excel VBA gibt, erklären viele Funktionen, aber ich habe bisher nur in einem gelesen, dass der vom Makrorecorder aufgezeichnete Code bereinigt werden sollte.
Der Makrorecorder zeichnet alle Aktionen auf, u. a. auch das Auswählen einer Zelle oder eines eingebetteten Objektes (Bild, Diagramm, Zeichnungsobjekt usw.) dabei wird generell Select und Activate aufgezeichnet. Diese Befehle sind in VBA zu 99,9% nicht notwendig. Sie lassen den Bildschirm flackern und senken die Geschwindigkeit bei der Ausführung des Codes. Man sollte also schon von Beginn an bei der Programmierung darauf achten, solche Befehle zu vermeiden. Meine Erfahrung mit dem Vorsatz: Das mache ich später ist, man schreibt das Programm später meist komplett neu. Also kostest es nicht nur Rechnerzeit sondern auch Deine Zeit und ist Dir Deine Zeit so wenig Wert?
Zum Vergleich mit und ohne Select schau Dir auch mal diese Beispielarbeitsmappe an: mit und ohne select Auf meiner Homepage sind alle meine Beispiele ohne Select. Da kann man sich also einige Lösungsansätze zu diesem Thema ansehen.

Anzeige
AW: Prozedur scheller machen?
23.09.2008 20:20:00
Lemmi
Hallo Hajo,
schau doch mal! ich glaube das alle Code von euch recht gut wahren! (das kann ich leider nciht so beurteilen da ich nicht so ein Könner bin!
Function myKW(newD As Date) As Integer
Dim myDay As Double
myDay = DateSerial(Year(newD + (8 - Weekday(newD)) Mod 7 - 3), 1, 1)
myKW = (newD - myDay - 3 + (Weekday(myDay) + 1) Mod 7) \ 7 + 1
End Function



Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, n As Long
If Target.Count > 1 Then Exit Sub 'nicht bei Markierung mehrerer Zellen
Set ws = ActiveSheet
n = 17
'bestimmte Excel-Aktivitäten abschalten
getMoreSpeed True
If Target.Column = n Then
'wenn die Anzahl der Aktivitäten im Change-Ereignis unübersichtlich werden, _
dann sollte man zusammenhängende Aktionen in Unterprozeduren auslagern und _
die aktive Tabelle sowie Target als Parameter übergeben
x_Felder_Setzen ws, Target, n
getMoreSpeed False
'und Tschüs...
Exit Sub
End If
'If Application.CutCopyMode Then Exit Sub 'nicht beim Kopieren/Ausschneiden
'Veränderungen im Bereich C6:P1000 werden in E3 mit Datum protokolliert
If Not Intersect(Target, ws.Range("C6:P1000")) Is Nothing Then
ws.Range("E3") = Now
'Veränderungen im Bereich E6:E1000 werden in derjewaligen Zeile in Spalte C mit Datum  _
_protokolliert; Aufnahme des Arbeitspunktes
If Not Intersect(Target, ws.Range("E6:F1000")) Is Nothing Then
ws.Range("C" & Target.Row) = Date
End If
'Veränderungen im Bereich G6:H1000,M6:M1000,P6:P1000 werden in derjewaligen Zeile und  _
Spalte N mit Datum protokolliert
If Not Intersect(Target, ws.Range("G6:H1000,M6:M1000,P6:P1000")) Is Nothing Then
ws.Range("N" & Target.Row) = Date
End If
'Veränderungen im Bereich H6:H1000 werden in derjewaligen Zelle (Spalte N)  mit Datum  _
protokolliert
If Not Intersect(Target, ws.Range("H7:H1000")) Is Nothing Then
'Target.Value = Target.Value & "  " & Now ' mit Datum und Uhrzeit: hh:mm:ss
'oder
'Target.Value = Target.Value & "  " & Date  ' nur mit Datum
'oder
' mit Datum und KW
Target.Value = Target.Value & ",   " & Date & ", KW" & myKW(Date) ' mit Datum und KW; _
Function myKW(newD As Date) As Integer ist hinzu gekommen
End If
End If
getMoreSpeed False
Set ws = Nothing
On Error GoTo ERRHDL
Application.EnableEvents = False
If Target.Count = 1 And Target.Column = 16 Then
Select Case LCase(Target.Value)
Case "erledigt": Target.Offset(0, -3) = 0
Case "offen":    Target.Offset(0, -3) = 2
Case "verworfen":    Target.Offset(0, -3) = ""
'Case "Status ?":    Target.Offset(0, -2) = "xxx"
End Select
End If
ERRHDL:
Application.EnableEvents = True
If Not Intersect(Target, Range("A6:AB500")) Is Nothing Then Call Update_Zellenhoehe
End Sub



Private Sub x_Felder_Setzen(y_ws As Worksheet, y_Target As Range, y_N As Long)
Dim rg1 As Range, rg2 As Range, rg3 As Range, _
s1 As String, _
n1 As Long, _
ok1 As Boolean, ok2 As Boolean
s1 = "x"
If s1 = y_Target.Value Then
'Zelle In Spalte 'A' gleiche Zeile
Set rg1 = y_Target.Offset(0, (-y_N + 1))
If "" = rg1.Value Then
'wenn Zelle in Spalte 'A' leer, dann Makro-Ende
Set rg1 = Nothing
y_Target.Value = ""
Exit Sub
Else
'Prüfen, ob in Spalte 'B' gleiche Zeile der Wert 0 steht, _
(1. Zeile Themenbereich)
ok1 = rg1.Offset(0, 1).Value = 0
End If
If ok1 Then
'wenn in Spallte B der Wert '0' steht (also 1. Zeile Themenbereich)
ok2 = True
'nächste Zelle in Spalte 'A'
Set rg2 = rg1.Offset(1, 0)
Do While ok2
'solange Schleife durchlaufen, wie in der nächsten Zelle in Spalte 'A' _
der gleiche Wert steht wie in der Zelle darüber
If rg2.Value = rg1.Value Then
'nicht jede Zelle in Spalte 'P' einzeln löschen, sondern erst _
alle Zellen erfassen
If rg3 Is Nothing Then
Set rg3 = rg2
Else
Set rg3 = Union(rg3, rg2)
Set rg2 = rg2.Offset(1, 0)
End If
Else
'Schleifenabbruch
ok2 = False
End If
Loop
If Not rg3 Is Nothing Then
'da die Zellen der Spalte 'A' erfaßt wurden, den Wertebereich um _
15 Spalten nach rechts verschieben (Spalte 'P')
rg3.Offset(0, (y_N - 1)).Value = ""
End If
Else
'wenn nicht 1. Zeile im Themenbereich
n1 = rg1.Value
'suchen des 1. Wertes (ist somit 1. Zeile im Themenbereich
'da die Zellen der Spalte 'A' formatiert sind, muß xlFormulas statt xlValues _
angegeben werden
Set rg1 = y_ws.Columns(1).Find(n1, , xlFormulas, xlWhole, xlByColumns, xlNext)
If Not rg1 Is Nothing Then
rg1.Offset(0, (y_N - 1)).Value = ""
End If
End If
End If
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
End Sub


Gruß
Lemmi

Anzeige
AW: Prozedur scheller machen?
23.09.2008 20:40:12
Hajo_Zi
Hallo Lemmi,
da sollte wohl eher der Ersteller ran. Mir ist nur ein Else if aufgefellen und das WS sinnlos ist.

Option Explicit
Function myKW(newD As Date) As Integer
Dim myDay As Double
myDay = DateSerial(Year(newD + (8 - Weekday(newD)) Mod 7 - 3), 1, 1)
myKW = (newD - myDay - 3 + (Weekday(myDay) + 1) Mod 7) \ 7 + 1
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Count > 1 Then Exit Sub 'nicht bei Markierung mehrerer Zellen
n = 17
'bestimmte Excel-Aktivitäten abschalten
getMoreSpeed True
If Target.Column = n Then
'wenn die Anzahl der Aktivitäten im Change-Ereignis unübersichtlich werden, _
dann sollte man zusammenhängende Aktionen in Unterprozeduren auslagern und _
die aktive Tabelle sowie Target als Parameter übergeben
x_Felder_Setzen Target, n
getMoreSpeed False
'und Tschüs...
Exit Sub
End If
'If Application.CutCopyMode Then Exit Sub 'nicht beim Kopieren/Ausschneiden
'Veränderungen im Bereich C6:P1000 werden in E3 mit Datum protokolliert
If Not Intersect(Target, Range("C6:P1000")) Is Nothing Then
Range("E3") = Now
'Veränderungen im Bereich E6:E1000 werden in derjewaligen Zeile in Spalte C mit Datum _
_protokolliert; Aufnahme des Arbeitspunktes
If Not Intersect(Target, Range("E6:F1000")) Is Nothing Then
Range("C" & Target.Row) = Date
ElseIf Not Intersect(Target, Range("G6:H1000,M6:M1000,P6:P1000")) Is Nothing Then
Range("N" & Target.Row) = Date
End If
'Veränderungen im Bereich H6:H1000 werden in derjewaligen Zelle (Spalte N)  mit Datum _
protokolliert
If Not Intersect(Target, Range("H7:H1000")) Is Nothing Then
'Target.Value = Target.Value & "  " & Now ' mit Datum und Uhrzeit: hh:mm:ss
'oder
'Target.Value = Target.Value & "  " & Date  ' nur mit Datum
'oder
' mit Datum und KW
Target.Value = Target.Value & ",   " & Date & ", KW" & myKW(Date) ' mit Datum und  _
KW; _
Function myKW(newD As Date) As Integer ist hinzu gekommen
End If
End If
getMoreSpeed False
On Error GoTo ERRHDL
Application.EnableEvents = False
If Target.Count = 1 And Target.Column = 16 Then
Select Case LCase(Target.Value)
Case "erledigt": Target.Offset(0, -3) = 0
Case "offen":    Target.Offset(0, -3) = 2
Case "verworfen":    Target.Offset(0, -3) = ""
'Case "Status ?":    Target.Offset(0, -2) = "xxx"
End Select
End If
ERRHDL:
Application.EnableEvents = True
If Not Intersect(Target, Range("A6:AB500")) Is Nothing Then Call Update_Zellenhoehe
End Sub
Private Sub x_Felder_Setzen(y_Target As Range, y_N As Long)
Dim rg1 As Range, rg2 As Range, rg3 As Range, _
s1 As String, _
n1 As Long, _
ok1 As Boolean, ok2 As Boolean
s1 = "x"
If s1 = y_Target.Value Then
'Zelle In Spalte 'A' gleiche Zeile
Set rg1 = y_Target.Offset(0, (-y_N + 1))
If "" = rg1.Value Then
'wenn Zelle in Spalte 'A' leer, dann Makro-Ende
Set rg1 = Nothing
y_Target.Value = ""
Exit Sub
Else
'Prüfen, ob in Spalte 'B' gleiche Zeile der Wert 0 steht, _
(1. Zeile Themenbereich)
ok1 = rg1.Offset(0, 1).Value = 0
End If
If ok1 Then
'wenn in Spallte B der Wert '0' steht (also 1. Zeile Themenbereich)
ok2 = True
'nächste Zelle in Spalte 'A'
Set rg2 = rg1.Offset(1, 0)
Do While ok2
'solange Schleife durchlaufen, wie in der nächsten Zelle in Spalte 'A' _
der gleiche Wert steht wie in der Zelle darüber
If rg2.Value = rg1.Value Then
'nicht jede Zelle in Spalte 'P' einzeln löschen, sondern erst _
alle Zellen erfassen
If rg3 Is Nothing Then
Set rg3 = rg2
Else
Set rg3 = Union(rg3, rg2)
Set rg2 = rg2.Offset(1, 0)
End If
Else
'Schleifenabbruch
ok2 = False
End If
Loop
If Not rg3 Is Nothing Then
'da die Zellen der Spalte 'A' erfaßt wurden, den Wertebereich um _
15 Spalten nach rechts verschieben (Spalte 'P')
rg3.Offset(0, (y_N - 1)).Value = ""
End If
Else
'wenn nicht 1. Zeile im Themenbereich
n1 = rg1.Value
'suchen des 1. Wertes (ist somit 1. Zeile im Themenbereich
'da die Zellen der Spalte 'A' formatiert sind, muß xlFormulas statt xlValues _
angegeben werden
Set rg1 = ActiveSheet.Columns(1).Find(n1, , xlFormulas, xlWhole, xlByColumns,  _
xlNext)
If Not rg1 Is Nothing Then
rg1.Offset(0, (y_N - 1)).Value = ""
End If
End If
End If
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
End Sub


Gruß Hajo

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige