Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender Navigationstipps
Inhaltsverzeichnis

Kombination von 2x Sub Worksheet_Change

Kombination von 2x Sub Worksheet_Change
21.02.2018 16:31:06
2x
Hallo zusammen,
hier das nächste "Problem".
Ich möchte in meiner Datei zwei verschiedene Subs "Worksheet_Change (ByVal Target as Range) kombinieren.
Geschrieben sind die beiden soweit auch fertig.
Einmal, aktuell auch schon funktionstüchtig, die Funktion, dass bei einer Werteeingabe in Spalte C automatisch das Datum in Spalte B eingefügt wird:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C11:C100")) Is Nothing Then
Cells(Target.Row, "B").Value = Date
End If
End Sub
Beim zweiten geht es darum, dass ich bei einer Dropdown Liste auch eine Mehrfachauswahl treffen kann
(Ich hoffe das ist soweit überhaupt richtig, konnte das noch nicht testen):
Private Sub Worksheet_Change2(ByVal Target As Range)
Dim rngDV As Range
Dim wertold As String
Dim wertnew As String
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Range("H11:H50")) Is Nothing Then
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
wertnew = Target.Value
Application.Undo
wertold = Target.Value
Target.Value = wertnew
If wertold  "" Then
If wertnew  "" Then
Target.Value = wertold & ", " & wertnew
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
End Sub
Nun habe ich herausgefunden, dass es immer nur ein Sub dieser Art in einer Tabelle geben kann und dass man diese beiden nun kombinieren müsste.
Leider habe ich das mit meinen mehr als bescheidenen VBA Kenntnissen irgendwie noch nicht bewerkstelligen können.
Gibt es vielleicht einen Kundigen, der mir da behilflich sein kann?
Danke & VG
Thomas

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kombination von 2x Sub Worksheet_Change
21.02.2018 16:44:07
2x
Hallo Thomas,
kopiere des zweite nach End If. Würde ich mal vermuten.

Ich gebe keinen Dank für eine Rückmeldung, da ich durch solche Beiträge nicht meine Beitragszahl erhöhen muss.
Also ich schreibe keine Beiträge mit dem Betreff "Gerne u. Danke für die Rückmeldung....."
Rückmeldung ist ja in der Heutigen Zeit nicht üblich und die wenigen die eine Rückmeldung geben,
mögen mir das verzeihen, das kein Danke für eine Rückmeldung kommt.
Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
AW: Kombination von 2x Sub Worksheet_Change
21.02.2018 16:49:23
2x
Hi, danke schon mal. Es mag so vielleicht auch funktionieren.
Allerdings klappt es bei mir nicht, was aber wahrscheinlich eher daran liegt, dass der 2. Code irgendwo einen Fehler hat.
Weiß wer wo da was falsch ist?
Danke & Gruß
Thomas
Anzeige
Dann hättest Du andersrum fragen müssen.
21.02.2018 17:15:31
lupo1
AW: Dann hättest Du andersrum fragen müssen.
22.02.2018 09:00:18
Thomas
Wieso hätte ich andersrum fragen müssen?
Ich dachte ja der Code ist korrekt. Aber da die mir vorgeschlagene Lösung nicht funktioniert, und ihr euch hier nun mal besser mit VBA auskennt, dachte ich, dass der Fehler wahrscheinlich auf meiner Seite liegt.
Die Frage war also durchaus richtig, es hat sich nur eine zweite, neue Frage ergeben.
ungetestet, App.EE verschoben
21.02.2018 16:45:38
lupo1

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim wertold As String
Dim wertnew As String
If Not Application.Intersect(Target, Range("H11:H50")) Is Nothing Then
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
wertnew = Target.Value
Application.Undo
wertold = Target.Value
Target.Value = wertnew
If wertold  "" Then
If wertnew  "" Then
Target.Value = wertold & ", " & wertnew
End If
End If
Application.EnableEvents = True
End If
End If
Errorhandling:
If Not Intersect(Target, Range("C11:C100")) Is Nothing Then
Cells(Target.Row, "B").Value = Date
End If
End Sub

Anzeige
AW: ungetestet, App.EE verschoben
22.02.2018 09:47:04
Thomas
Danke für die Mühe, aber so funktionieren beide Makros nicht.
Beim ersten Ausführen gab es auch einen Debug bei
" Application.Undo"
Danach allerdings nicht mehr. Jedoch wird das Datum nicht mehr eingefügt und die Mehrfachauswahl geht leider auch nicht.
VG
Tja, mit VBA ist das halt so eine Sache ...
22.02.2018 17:01:53
lupo1
... es testet sich ohne Datei nicht so einfach.

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige