kleines Problem mit Worksheet_Change
06.12.2020 10:08:36
Peter
einen schönen guten Morgen.
Ich habe nur ein kleines Problem und möchte euch Bitten zu prüfen, ob es eine andere Möglichkeit gibt, um den nachfolgenden Code zu beschleunigen.
Wenn in der Spalte S eine Zahl eingebeben wird, wird der Code ausgeführt. Dieser Code wird 6 Mal durchlaufen.
Gibt es eine Möglichkeit dies kürzer zu gestalten?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Dim wksGB As Worksheet
Dim Name As String
Dim wksBu2 As Worksheet
Dim wksKI As Worksheet
Dim lngLetzteKIA As Long
Dim raBereichKIA As Range
Dim wksKd As Worksheet
Dim lngLetzteKdA As Long
Dim raBereichKdA As Range
Dim SuWert As Range
Set wb = ThisWorkbook
Set wksGB = wb.Worksheets("Gesamtbuchungen")
Name = wksGB.Range("AC2")
Set wksBu2 = wb.Worksheets(Name)
Set wksKI = wb.Worksheets("Kontoinhaber")
Set wksKd = wb.Worksheets("Kontodaten")
Set SuWert = wksBu2.Range("G5")
'Code in das entsprechende Tabellenblatt!
If Not Intersect(Target, Range("S2:S" & Cells(Rows.Count, "S").End(xlUp).Row)) Is Nothing _
And Target.Count = 1 Then
If Target > 0 Then
'Anfang - übertragen Anfangs-und Enddatum und Buchungsjahr
Cells(Target.Row, 1) = CDate(wksBu2.Range("L2")) 'funktioniert
Cells(Target.Row, 2) = CDate(wksBu2.Range("L3")) 'funktioniert
Cells(Target.Row, 3) = CDate(wksBu2.Range("L3")) & " - " & CDate(wksBu2.Range("L3")) _
'funktioniert
'Ende - übertragen Anfangs-und Enddatum und Buchungsjahr
'Anfang Übertragen Kontoinhaberdaten
With wksKI
lngLetzteKIA = .Range("A:A").Cells.Find("*", LookIn:=xlValues, searchdirection:= _
xlPrevious).Row
Set raBereichKIA = .Range(.Cells(lngLetzteKIA, 1), .Cells(lngLetzteKIA, 5))
raBereichKIA.Copy
Cells(Target.Row, 4).PasteSpecial xlPasteValues
End With
'Ende Übertragen Kontoinhaberdaten
'Anfang Übertragen Kontodaten
With wksKd
lngLetzteKdA = .Range("F:F").Cells.Find(SuWert, LookIn:=xlValues, _
searchdirection:=xlPrevious).Row
Set raBereichKdA = .Range(.Cells(lngLetzteKdA, 1), .Cells(lngLetzteKdA, 10))
raBereichKdA.Copy
Cells(Target.Row, 9).PasteSpecial xlPasteValues
End With
'Ende Übertragen Kontodaten
Application.CutCopyMode = False 'kopierten Bereich aufheben
End If
End If
Set SuWert = Nothing
Set wksKd = Nothing
Set wksKI = Nothing
Set wksBu2 = Nothing
Set wksGB = Nothing
Set wb = Nothing
End Sub
Besten DankGruss
Peter