Doppelklick zwei Bereiche ansprechen

Hallo!
Ich habe zwei 2.Problem:
Und hoffe das ihr mir helfen könnt.
Nachfolgendes Makro läuft so einband frei.
'


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [D11:D500]) Is Nothing Then Exit Sub
If Cells(Target.Row, 7) = "" Then Exit Sub 'Kein Name -> Abbruch
With Worksheets("Stundenzettel")
.Range("H8") = Cells(Target.Row, 7).Text
Cancel = True
Application.Goto .Range("H7")
End With
End Sub

Hier mein 1. Problem
Es wird mit Doppelklick der Name in Stundenzettel H7 ein getragen.
Der Doppelklick wird in Übersichtstafel ausgeführt.
Nun möchte ich beim nächsten Doppelklick das H7 geprüft wird,
Wenn was drin steht soll der Eintrag dann in Zelle H29 eingetragen werde. Wenn Zelle auch einen Eintrag dann nächste Zellen prüfen und befüllen. Und so weiter.
Folgende Zelle sind noch vorhanden
H55 / H78 / H105/ H128/ H158/ H177/ H204/ H227
Ich hoffe ich habe mich einiger maßen verständlich ausgedrückt.
Der zweite Punkt ist das dieses Makro mit Doppelklick mit einem anderen Makro mit Doppelklick in der Tabelle Übersichtstafel laufen soll.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [F11:L500]) Is Nothing Then Exit Sub
If Cells(Target.Row, 7) = "" Then Exit Sub 'Kein Name -> Abbruch
With Worksheets("Rechnungsformular")
.Range("C20") = Cells(Target.Row, 6).Text
.Range("C21") = Cells(Target.Row, 7).Text
.Range("C22") = Cells(Target.Row, 8).Text
.Range("C24") = Cells(Target.Row, 9).Text
.Range("C30") = Cells(Target.Row, 10).Text
.Range("AQ38") = Cells(Target.Row, 12).Text
.Range("AQ39") = Cells(Target.Row, 11).Text
Cancel = True
Application.Goto .Range("C21")
End With

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [D11:E500]) Is Nothing Then Exit Sub
If Cells(Target.Row, 7) = "" Then Exit Sub 'Kein Name -> Abbruch
With Worksheets("Stundenzettel")
.Range("H8") = Cells(Target.Row, 7).Text
Cancel = True
Application.Goto .Range("H8")
End With
End Sub


Hier meine Tabelle:

https://www.herber.de/bbs/user/139785.xlsm


Ich hoffe das es verständlich ist.

Wäre schön, wenn ihr mir hier bei helfen könntet.

Grüß Ralf

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, [F11:L500]) Is Nothing Then If Cells(Target.Row, 7) "" Then With Worksheets("Rechnungsformular") .Range("C20") = Cells(Target.Row, 6).Text .Range("C21") = Cells(Target.Row, 7).Text .Range("C22") = Cells(Target.Row, 8).Text .Range("C24") = Cells(Target.Row, 9).Text .Range("C30") = Cells(Target.Row, 10).Text .Range("AQ38") = Cells(Target.Row, 12).Text .Range("AQ39") = Cells(Target.Row, 11).Text Cancel = True Application.Goto .Range("C21") End With End If Else If Not Intersect(Target, [D11:E500]) Is Nothing Then If Cells(Target.Row, 7) "" Then With Worksheets("Stundenzettel") .Range("H8") = Cells(Target.Row, 7).Text Cancel = True Application.Goto .Range("H8") End With End If End If End If End Sub

Hallo Werner
Hier noch mal meine Mappe
https://www.herber.de/bbs/user/139785.xlsm
Zu deiner Frage ja, wenn ich in zum Beispiel in D11 klicke dann steht in G11 dort der Name.
Also die vorgehen weise ist so gedacht.
Doppelklick in Übersichtstafel in Spalte D ( Kd. Nr. ) der Name aus
Spalte G der gleichen Zelle kopieren und in Stundenzettel in Zelle H7 einfügen. Wenn in H7 aber schon ein Name steht soll er den Namen in Zelle H29 eintragen. Wenn hier auch ein Name steht dann immer so weiter in die Folgenden Zelle die noch vorhanden sind
H55 / H78 / H105/ H128/ H158/ H177/ H204/ H227
Wenn H227 auch ein Name dann so wie bei dir
MsgBox "Fehler: Nichts mehr frei."
Ich hoffe ich habe es jetzt einiger maßen erklärt
Ich hoffe du kannst helfen.
Gruß Ralf

Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim raBereich As Range, raZelle As Range Dim boEintrag As Boolean Application.ScreenUpdating = False If Not Intersect(Target, [F11:L500]) Is Nothing Then If Cells(Target.Row, 7) "" Then With Worksheets("Rechnungsformular") .Range("C20") = Cells(Target.Row, 6).Text .Range("C21") = Cells(Target.Row, 7).Text .Range("C22") = Cells(Target.Row, 8).Text .Range("C24") = Cells(Target.Row, 9).Text .Range("C30") = Cells(Target.Row, 10).Text .Range("AQ38") = Cells(Target.Row, 12).Text .Range("AQ39") = Cells(Target.Row, 11).Text Cancel = True Application.Goto .Range("C21") End With End If Else If Not Intersect(Target, [D11:E500]) Is Nothing Then If Cells(Target.Row, 7) "" Then Cancel = True With Worksheets("Stundenzettel") Set raBereich = Union(.Range("H7"), .Range("H29"), .Range("H55"), _ .Range("H78"), .Range("H105"), .Range("H128"), .Range("H158"), _ .Range("H177"), .Range("H204"), .Range("H227")) For Each raZelle In raBereich If raZelle = "" Then raZelle = Cells(Target.Row, 7).Text boEintrag = True Application.Goto .Range("H8") Exit For End If Next raZelle If Not boEintrag Then MsgBox "Fehler: Nichts mehr frei." End If End With End If End If End If End Sub

Beliebteste Forumthreads (12 Monate)

Doppelklick zwei Bereiche ansprechen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread