Zeile nach Status in anderes Blatt verschieben
29.01.2024 15:51:15
Max
ich habe einen VBA Code der im oberen Teil folgendes macht: Je nach Statusvergabe in einer Zelle in Spalte B verschiebt er die gesamte Zeile in ein anderes Tabellenblatt. Das funktionierte auch immer wunderbar bis ich den unteren Teil ergänzt habe.
Hier geht es wiederum darum, dass in Spalte J bzw. 10 ein Dropdownmenü hinterlegt ist bei dem eine Mehrfachaus- und abwahl stattfindet. Es geht um Ausstattungsauswahl von Fahrzeugen.
So jetzt zurück zum oberen Teil. Das kopieren der Zeile in ein anderes Tabellenblatt wird ausgeführt. Leider wird aber die ursprüngliche Zeile dabei nicht gelöscht. Ich habe somit die gleiche Zeile im alten und im neuen Blatt.
Kann mir jemand helfen Ordnung in die Codes zu bringen? Ich denke es liegt an dem Durcheinander das ich mit dem 2 Code kreiert habe.
Hilft es wenn ich die Exceldatei hochlade?
LG Max
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngErste As Long
If Target.Column = 2 Then
If Target.Count = 1 Then
If Target = "Bestand" Then
With Worksheets("Bestand")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With
ElseIf Target = "Verkauft" Then
With Worksheets("Verkauft")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With
ElseIf Target = "Abgerechnet" Then
With Worksheets("Abgerechnet")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With
End If
End If
End If
Application.EnableEvents = True
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String
If Target.Cells.Count > 1 Then End
On Error Resume Next
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
If rngDropdown Is Nothing Then GoTo exitError
If Not Target.Column = 10 Then GoTo exitError
TargetType = 0
TargetType = Target.Validation.Type
If TargetType = 3 Then ' is validation type is "list"
Application.ScreenUpdating = False
Application.EnableEvents = False
newValue = Target.Value
Application.Undo
oldValue = Target.Value
Target.Value = newValue
If oldValue > "" Then
If newValue > "" Then
If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
oldValue = Replace(oldValue, DelimiterType, "")
oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
Target.Value = oldValue
ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
arr = Split(oldValue, DelimiterType)
If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
Target.Value = oldValue & DelimiterType & newValue
Else:
Target.Value = ""
For i = 0 To UBound(arr)
If arr(i) > newValue Then
Target.Value = Target.Value & arr(i) & DelimiterType
End If
Next i
Target.Value = Left(Target.Value, Len(Target.Value) - Len(DelimiterType))
End If
ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
oldValue = Replace(oldValue, newValue, "")
Target.Value = oldValue
Else
Target.Value = oldValue & DelimiterType & newValue
End If
Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
Target.Value = Replace(Target.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
If Target.Value > "" Then
If Right(Target.Value, 2) = DelimiterType Then ' remove delimiter at the end
Target.Value = Left(Target.Value, Len(Target.Value) - 2)
End If
End If
If InStr(1, Target.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
Target.Value = Replace(Target.Value, DelimiterType, "", 1, 1)
End If
If InStr(1, Target.Value, Replace(DelimiterType, " ", "")) = 1 Then
Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
End If
DelimiterCount = 0
For i = 1 To Len(Target.Value)
If InStr(i, Target.Value, Replace(DelimiterType, " ", "")) Then
DelimiterCount = DelimiterCount + 1
End If
Next i
If DelimiterCount = 1 Then ' remove delimiter if last character
Target.Value = Replace(Target.Value, DelimiterType, "")
Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", ""), "")
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
exitError:
Application.EnableEvents = True
End Sub
Anzeige