Dim oldValue As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim rngDropdown As Range
Dim dataRange As Range
Dim cell As Range
Set ws = ThisWorkbook.Worksheets("Eingabedialog")
Set rngDropdown = ws.Range("G4")
If Not Intersect(Target, rngDropdown) Is Nothing Then
If Target.Value = "" Then
Set dataRange = ThisWorkbook.Worksheets("Rohdaten").Range("A3:G" & ThisWorkbook.Worksheets("Rohdaten").Cells(ThisWorkbook.Worksheets("Rohdaten").Rows.Count, "A").End(xlUp).Row)
For Each cell In dataRange
If cell.Value = oldValue Then
cell.EntireRow.Delete
UpdateDropdown ws, rngDropdown, dataRange
MsgBox "Eintrag und entsprechende Zeile wurden gelöscht."
Exit Sub
End If
Next cell
MsgBox "Der ausgewählte Eintrag wurde in der Tabelle nicht gefunden."
Else
oldValue = Target.Value
End If
End If
If Target.Address(0, 0) = "G4" And Target.Value <> "" Then
selectedOption = Me.Range("G4").Value
With Sheets("Rohdaten")
searchData = Application.Match(selectedOption, .Columns(1), 0)
If IsNumeric(searchData) Then
Application.EnableEvents = False
Me.Range("J13:J17") = WorksheetFunction.Transpose(.Cells(searchData, 2).Resize(1, 5))
Application.EnableEvents = True
Else
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lastRow, 1).Value = selectedOption
Application.EnableEvents = False
Me.Range("J13:J17").ClearContents
Application.EnableEvents = True
End If
End With
Else
If Not Intersect(Target, Me.Range("J13:J17")) Is Nothing Then
If Me.Range("G4").Value <> "" Then
With Sheets("Rohdaten")
searchData = Application.Match(Me.Range("G4").Value, .Columns(1), 0)
If IsNumeric(searchData) Then
.Cells(searchData, 2).Resize(1, 5).Value = WorksheetFunction.Transpose(Me.Range("J13:J17").Value)
End If
End With
End If
End If
End If
End Sub
Sub UpdateDropdown(ws As Worksheet, rngDropdown As Range, dataRange As Range)
Dim uniqueValues As Collection
Dim cell As Range
Dim arr() As String
Dim i As Long
Set uniqueValues = New Collection
On Error Resume Next
For Each cell In dataRange
If cell.Value <> "" Then
uniqueValues.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0
If uniqueValues.Count > 0 Then
ReDim arr(1 To uniqueValues.Count)
For i = 1 To uniqueValues.Count
arr(i) = uniqueValues(i)
Next i
With rngDropdown.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Becken"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Else
With rngDropdown.Validation
.Delete
End With
End If
End Sub