Code Ausführung sehr langsam
27.06.2021 16:11:00
Philipp
seit kurzem wird der folgend beschriebene VBA-Code sehr langsam ausgeführt. Schon beim Öffnen der Tabelle dauert es sehr lange bis Eingaben gemacht werden können.
Das merkwürdige ist, dass sich die Bearbeitungszeit verlängert hat ohne das ich Veränderungen vorgenommen habe.
Alle anderen Tabellen sind nicht betroffen und deren VBA Code läuft einwandfrei. Ich hoffe, dass jemand anhand der Beschreibung und dem Code einen Grund für die Langsamkeit entdecken kann.
1. Beschreibung:
in einer Tabelle (Stammdaten) der Arbeitsmappe stehen Personaldaten. Um das Personal schneller zu finden gibt es zwei Comboboxen.
Bei Eingabe der Personalnummer (Combobox 1) oder Nachnamen (Combobox 2) sucht eine "For/ Next Schleife" nach Übereinstimmungen in den Personalstammdaten.
Wird eine Übereinstimmung gefunden, wird die in Spalte A befindliche Personalnummer angewählt und das Fenster an die entsprechende Position gescrollt.
Anhand der Personalnummer in Spalte A wird in den Zeilen A2 bis A6 das Foto des Mitarbeiters angezeigt.
Durch Doppelklick in eine beliebige Zeile mit Personaldaten öffnet eine UserForm in der die Personaleinzelansicht zu sehen ist. Des Weiteren können ihr Eingaben gemacht werden, die dann in die Stammdatentabelle übernommen werden. Das Personal kann auch gelöscht werden. Des Weiteren kann das Personal in andere Tabellen übernommen werden.
Sobald Eintragungen in der Tabelle Stammdaten gemacht werden läuft auch die UserForm sehr langsam, sodass ich vermute, dass der Fehler im unten stehenden Code der Tabelle Stammdaten steckt.
Wäre über jeden Tipp oder Hinweis sehr dankbar!
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Unprotect Password:="UB"
If Not Intersect(Target, Range("A8:A1000")) Is Nothing Then ActiveCell.Copy Destination:=Tabelle2.Range("A1")
On Error Resume Next
If Not Intersect(Target, Range("B8:B1000")) Is Nothing Then ActiveCell.Offset(0, -1).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("C8:C1000")) Is Nothing Then ActiveCell.Offset(0, -2).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("D8:D1000")) Is Nothing Then ActiveCell.Offset(0, -3).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("E8:E1000")) Is Nothing Then ActiveCell.Offset(0, -4).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("F8:F1000")) Is Nothing Then ActiveCell.Offset(0, -5).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("G8:G1000")) Is Nothing Then ActiveCell.Offset(0, -6).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("H8:H1000")) Is Nothing Then ActiveCell.Offset(0, -7).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("I8:I1000")) Is Nothing Then ActiveCell.Offset(0, -8).Copy Destination:=Tabelle2.Range("A1")
If Not Intersect(Target, Range("J8:I1000")) Is Nothing Then ActiveCell.Offset(0, -9).Copy Destination:=Tabelle2.Range("A1")
Dim cDir As String
Dim trname As String
Const sPath As String = "B:\Gemeinsame Daten\Fahrtechnik\Bilder Dienstausweise\"
' Const sPath As String = "F:\Eigene Dateien von Philipp\KVB\Fahrmeister\Bilder Dienstausweise\"
trname = Worksheets("Stammdaten").Range("A1").Text
cDir = Dir(sPath & trname & "*.jpg")
If Range("A1") > "" Then
Image1.Picture = LoadPicture(sPath & cDir)
Image1.PictureSizeMode = fmPictureSizeModeZoom
Else: Image1.Picture = LoadPicture("")
End If
Protect Password:="UB"
End Sub
Private Sub CheckBox1_Click()
ActiveSheet.Columns("K:K").Hidden = Not (CheckBox1)
End Sub
Private Sub ComboBox1_Change() 'Feld zur Eingabe der Personalnummer
'Variablen ihrem Typ zuweisen
Dim Wiederholungen As Long, Auswahl As String
ComboBox2 = ""
'Angezeigten Wert aus Kombinationsfeld1 in Variable "Auswahl" schreiben
Auswahl = ComboBox1
'e zum Finden von Übereinstimmungen des Inhaltes der
'Variablen "Auswahl"
For Wiederholungen = 8 To 4000
'Abfrage: Wenn Kombinationsfeld leer dann zur Sprungmarke "Ende" springen
If Cells(Wiederholungen, 1) = "" Then GoTo Ende
'Abfrage: Wenn Inhalt der angesprochenen Zelle gleich dem Inhalt der
'Variablen "Auswahl", dann...
' If Left$(Cells(Wiederholungen, 1).Text, Len(Auswahl)) = Auswahl Then
If Cells(Wiederholungen, 1) = Auswahl Then
'Zelle markieren,
Cells(Wiederholungen, 1).Select
'Fenster an die entsprechende Position scrollen
ActiveWindow.ScrollColumn = ActiveWindow.ActiveCell.Column
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
'Kombinationsfeld zur weiteren Eingabe wieder aktivieren
ComboBox1.Activate
'Abfrage Ende
End If
'Nächsten Schleifendurchlauf starten
Next
'Sprungmarke
Ende:
'Worksheets("Stammdaten").ComboBox1.Value = ""
End Sub
Private Sub ComboBox2_Change() 'Feld zur Eingabe des Nachnamens
'Variablen ihrem Typ zuweisen
Dim Wiederholungen As Long, Auswahl As String
ComboBox1 = ""
'Angezeigten Wert aus Kombinationsfeld1 in Variable "Auswahl" schreiben
Auswahl = ComboBox2
'For/ Next Schleife zum Finden von Übereinstimmungen des Inhaltes der
'Variablen "Auswahl"
For Wiederholungen = 8 To 4000
'Abfrage: Wenn Kombinationsfeld leer dann zur Sprungmarke "Ende" springen
If Cells(Wiederholungen, 11) = "" Then GoTo Ende
'Abfrage: Wenn Inhalt der angesprochenen Zelle gleich dem Inhalt der
'Variablen "Auswahl", dann...
If Cells(Wiederholungen, 11) = Auswahl Then
'Zelle markieren,
Cells(Wiederholungen, 1).Select
'Fenster an die entsprechende Position scrollen
ActiveWindow.ScrollColumn = ActiveWindow.ActiveCell.Column
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
'Kombinationsfeld zur weiteren Eingabe wieder aktivieren
ComboBox2.Activate
'Abfrage Ende
End If
'Nächsten Schleifendurchlauf starten
Next
'Sprungmarke
Ende:
End Sub
Private Sub CommandButton1_Click()
ComboBox2 = ""
ComboBox1 = ""
frm_Suche.Show
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("A8:I1000")) Is Nothing Then Exit Sub
Cancel = True
ComboBox2.ListIndex = -1 'Leert den Text (Fahrpersonalnamen) aus der ComboBox2
ComboBox1.Value = "" 'Leert die Personalnummer aus der ComboBox1
frm_Fahrpersonal_Einzelansicht.Show
End Sub
Private Sub worksheet_Beforeopen()
ComboBox1 = ""
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
End Sub