Gesprächsnotizen übertragen UweD

Ralf · 2020-06-01T13:45:08+00:00

Hallo, Ich hätte da noch zwei Sachen; 1.Sache Wenn ich den Kunden in der MASKE "B3" aufgerufen habe, erscheint rechts in der Gesprächsnotiz in den Spalten "O10 bis O27 " die Gesprächsnotizen, die ich in der Datenbank in den Spalten "AO bis BF" eingetragen habe. Nun wäre es sinnvoller jeweils aus der Maske heraus in der Spalte "O10 bis O27 " die Gesprächsnotizen einzutragen und nach Abschluß durch ( Datum "D27" und Zeit "G27" ___erledigt__ abzuspeichern ( Die Gesprächnotizen sollen nach Abschluß nicht gelöscht werden) . Alle anderen clearings sollen bestehen bleiben !!! 2.Sache Nach Abschluß des Vorgangs durch Datum "D27" und Zeit "G27" soll in der Maske "B3" wieder aus "A1" und "D3" wieder auf "B1" zugreifen ( faktisch Grundeinstellung, somit wird immer der letzte Kunde aus der Datenbank ausgewiesen ) Die aktuelle Version findest du hier: https://www.herber.de/bbs/user/137924.xlsm

Hallo
so?


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TB As Worksheet, Kunu, Datum, Zeit, Zeile As Long
Dim SpK As Integer, SpD As Integer, SpR As Integer, SpG As Integer
Dim RNG1 As Range, RNG2 As Range, RNG3 As Range
'On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Set TB = Sheets("Datenbank")
SpK = 4 'Spalte der Kundennummer =D
SpD = 14 'Spalte mit Datum =N
SpR = 8 'Spalte mit Restdaten =H
SpG = 41 'Spalte mit Gespächsnotizen = AO
Set RNG1 = Range("B25:G25") 'Restdaten
Set RNG2 = Range("D27,G27") 'Datum Uhrzeit
Set RNG3 = Range("O10:O27") 'Notizen
'nur bei Änderungen in diesen Zellen auslösen
If Not Intersect(Union(RNG1, RNG2), Target) Is Nothing Then
Kunu = Range("B3")
If WorksheetFunction.CountIf(TB.Columns(SpK), Kunu) > 0 Then
'Kunde bereits vorhanden?
Zeile = WorksheetFunction.Match(Kunu, TB.Columns(SpK), 0)
Else
'Kunde nicht vorhanden?
MsgBox "Kundennummer nicht gefunden"
Exit Sub
End If
If Not Intersect(RNG1, Target) Is Nothing Then
'Restdaten eintragen
TB.Cells(Zeile, SpR).Offset(0, Target.Column - 2) = Target
End If
If Not Intersect(RNG2, Target) Is Nothing Then
Datum = Range("D27")
Zeit = Range("G27")
'Datum / Zeit; Beides muss eingetragen sein
If IsDate(Datum) And IsNumeric(Zeit) And Zeit  0 Then
'Zeit und Datum eintragen
TB.Cells(Zeile, SpD) = Datum
TB.Cells(Zeile, SpD + 1) = Format(Zeit, "hh:mm")
'Gesprächsnotizen eintragen
TB.Cells(Zeile, SpG).Resize(1, 18).Value = _
Application.Transpose(RNG3)
'KD Nr. Matchcode eintragen
Range("B3").FormulaR1C1 = "=R1C1" 'als Formel
Range("D3").FormulaR1C1 = "=R1C2"
'oder *****
Range("B3") = Range("A1") 'als Wert
Range("D3") = Range("B1")
'reset
Application.EnableEvents = False
RNG1 = "": RNG2 = ""
Application.EnableEvents = True
MsgBox "Erledigt"
End If
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

guten morgen,
in Maske "A1" bekomme ich die Kundennumer ( in "F1" stehen die =wenn....wennn...wenn.... die stehen im Zusammenhang mit Schreiben, Verlagen, etc.)
In Maske "B1" bekommen ich den Matchcode aus der Datenbank.
Nun ist ja eins wenn ich den Kunden 11 in die Maske "B3" eintrage, bekomme ich via "B1" in der Maske "D3"
den passenden Kunden ausgewiesen und automatisch in Maske "D4:D22" alle Kundendaten.
Dein Code mit der Kundennummer Maske "B3" funktioniert super ( geht immer auf max:Kundennummer) jedoch muss auch "D3" regenriert werden.
Nach Abschluß _____erledigt_____ geht "B3" in die Unsprungsstellung zurück und auch "D3" macht das, jedoch wenn ich jetzt einen neuen Kunden eingebe auf "B3" regeneriert sich "D3" nicht.
Im Prinzip müsste nach ____erledigt____ "B3" immer auf "A1" zugreifen und "D3" müsste auf "B1" zugreifen.
So das beim nächsten Kunden in der Maske "B3" den ich eingebe z.B. 22 auch "D3" den aktuellen Kunden ausweist und damit habe ich dann auch alle Kundendaten in der Maske "D4:D22"
"""die aktuelle Kd._Nr. und Matchcode siehst zu oben links stehen rote """"
wegen der Notiz habe ich die Maske umgebaut. aber komme ich später noch drauf.
Gruß Ralf

Gesprächsnotizen übertragen UweD

Forumthread: Gesprächsnotizen übertragen UweD

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Gesprächsnotizen übertragen UweD

Forumthread: Gesprächsnotizen übertragen UweD

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread