Option
Explicit
Option
Compare Text
Private
Sub
Workbook_SheetChange(
ByVal
Sh
As
Object
,
ByVal
Target
As
Range)
Dim
wksSearch
As
Excel.Worksheet
Select
Case
Sh.Name
Case
"Transporter"
Set
wksSearch = ThisWorkbook.Worksheets(
"Termine"
)
Case
"Termine"
Set
wksSearch = ThisWorkbook.Worksheets(
"Transporter"
)
Case
Else
Exit
Sub
End
Select
If
Intersect(Target, Sh.Range(
"B:C"
))
Is
Nothing
Then
Exit
Sub
End
If
Dim
rngSearch
As
Excel.Range
Dim
strFullName
As
Variant
strFullName = Trim$(Sh.Cells(Target.Row,
"B"
)) &
","
& Trim$(Sh.Cells(Target.Row,
"C"
))
If
Left$(strFullName, 1) =
","
Or
Right$(strFullName, 1) =
","
Then
Exit
Sub
End
If
With
wksSearch
Set
rngSearch = .Range(.Cells(.Rows.Count,
"B"
).
End
(xlUp), .Cells(.Rows.Count,
"C"
).
End
(xlUp))
If
rngSearch.Row >= 2
Then
Set
rngSearch = .Range(.Cells(2,
"B"
), .Cells(rngSearch.Row,
"C"
))
Else
Exit
Sub
End
If
End
With
Application.EnableEvents =
False
With
rngSearch
.EntireColumn(1).Insert xlShiftToRight
.Columns(0).FormulaR1C1 =
"=CONCAT(TRIM(RC[1]),"
","
",TRIM(RC[2]))"
If
.Columns(0).Find(strFullName, , xlValues, xlWhole, xlByColumns,
False
,
False
,
False
)
Is
Nothing
Then
strFullName =
""
End
If
.EntireColumn(0).Delete xlShiftToLeft
End
With
Application.EnableEvents =
True
If
strFullName <>
""
Then
MsgBox
"Der Name '"
& Replace$(strFullName,
","
,
", "
) &
"' ist bereits im Blatt '"
& wksSearch.Name &
"' vorhanden."
, _
vbExclamation
End
If
End
Sub