|
Hallo zusammen
Folgender Code habe ich aus dem Internet und der Funktioniert auch wie er sollte.......
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("H8:H1000")) Is Nothing Then
With ActiveSheet.OLEObjects("Firma")
.LinkedCell = Target.Address ' Zellverknüpfung ist die Zieladresse
.Top = Target.Top ' Position oben
.Left = Target.Left ' Position links
.Width = Target.Width ' Breite
.Height = Target.Height * 2 ' Höhe
.Object.MatchRequired = True ' nur vorhandene Einträge
.Object.ListRows = 20 ' Zeilenanzahl der Liste
.Object.Font.Size = 10 ' Schriftgröße
.Visible = True
.Object.DropDown ' DropDown öffnen
.Activate ' aktivieren
End With
ElseIf Not Intersect(Target, Range("N8:N1000")) Is Nothing Then
With ActiveSheet.OLEObjects("Kontakt")
.LinkedCell = Target.Address ' Zellverknüpfung ist die Zieladresse
.Top = Target.Top ' Position oben
.Left = Target.Left ' Position links
.Width = Target.Width ' Breite
.Height = Target.Height * 2 ' Höhe
.Object.MatchRequired = True ' nur vorhandene Einträge
.Object.ListRows = 20 ' Zeilenanzahl der Liste
.Object.Font.Size = 10 ' Schriftgröße
.Visible = True
.Object.DropDown ' DropDown öffnen
.Activate ' aktivieren
End With
ElseIf Not Intersect(Target, Range("G8:G1000")) Is Nothing Then
With ActiveSheet.OLEObjects("Badge")
.LinkedCell = Target.Address ' Zellverknüpfung ist die Zieladresse
.Top = Target.Top ' Position oben
.Left = Target.Left ' Position links
.Width = Target.Width ' Breite
.Height = Target.Height * 2 ' Höhe
.Object.MatchRequired = True ' nur vorhandene Einträge
.Object.ListRows = 20 ' Zeilenanzahl der Liste
.Object.Font.Size = 10 ' Schriftgröße
.Visible = True
.Object.DropDown ' DropDown öffnen
.Activate ' aktivieren
End With
Else
ActiveSheet.OLEObjects("Firma").Visible = False
ActiveSheet.OLEObjects("Kontakt").Visible = False
ActiveSheet.OLEObjects("Badge").Visible = False
End If
End Sub
Nun möchte ich auf dem gleichen Tabellenblatt noch folgenden Code ausführen aber weiss nicht wie ich diesen integriere.
Private Sub Worksheet_Change(ByVal Target As Range)
'bearbeiten mehrerer Zeilen wird abgefangen
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("D8:D1000,Q8:P1000")) Is Nothing Then Exit Sub
If Target.Value = "Name1" Or Target.Value = "Name2" Or Target.Value = "Name3" Or Target.Value = "Name4" Or Target.Value = "Name5" Or Target.Value = "Name6" Then
Target.Offset(0, 1) = Format(Date, "dd.mm.yyyy")
Target.Offset(0, 2) = Format(Time, "hhmm")
Else
Target.Offset(0, 1).ClearContents
Target.Offset(0, 2).ClearContents
End If
End Sub
Merci
Gruss Markus
|