mit Doppelklick Datum setzen

04.03.2025 10:46:29

sigrid

Guten Morgen,
ich habe nochmal eine kleine Frage:
Kann man das Datum (siehe Button mit der Beschriftung) auch mit Doppelklick oder einfachen
klick in A4 setzen ?

Anbei nochmal das Muster: https://www.herber.de/bbs/user/176110.xlsm

mfg sigrid

Sorry, hatte von gestern übersehen --))

04.03.2025 10:50:24

sigrid

AW: mit Doppelklick Datum setzen

04.03.2025 13:27:39

Charles

Hallo Sigrid,
es gab schon viele Nachrichten = Threads hier, aber was mich z.T. wundert diese "Dateien-Überflut".
Es mag sein, dass "Profis" hier einen Durchblick haben, aber "nur" um eine Userform zu verschieben oder in der Größe ändern, lässt nicht viel #Spielraum für eine Lösung.
Die entsprechenden Codes:

Option Explicit ' Variablendefinition erforderlich

Public Function getStrPasswort() As String
' getStrUpdate = ThisWorkbook.Worksheets("Laufende").Range("UpdateString")
Dim Passwort
''With ThisWorkbook.Worksheets("Lauf+Abge")
'' Passwort = .Range("AM2")
'' End With
getStrPasswort = "wwpa"
End Function

Private Sub CommandButton8_Click()
Unload Me
' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPasswort

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' Damit mit X nicht geschloßen werden kann
If CloseMode = 0 Then
' MsgBox "Mein Vorname ist ""Herbert"".", vbCritical
MsgBox "Bitte mit Button ""schließen"" beenden ", vbCritical
Cancel = 1
End If
End Sub

Private Sub UserForm_activate() ' Ereignis bei Start der UserForm
' Jahr eintragen
Dim InI

For InI = 1900 To 2100
Cbo_Jahr.AddItem InI ' Jahr eintragen
Next InI
Cbo_Jahr.Tag = 1 ' damit Erstellen bei Change nicht ausgelöst
Cbo_Jahr = Year(Date) ' Anzeige des aktuellen Jahres
Cbo_Jahr.Tag = "" ' damit Erstellen bei Change ausgelöst wird
' aktuelles Datum anzeigen Monat und Jahr anzeigen
Lbl_Datum = Format(Date, "MMMM YYYY")
' Monate eintragen
For InI = 1 To 12
Cbo_Monat.AddItem Format(DateSerial(Year(Date), _
InI, 1), "MMMM") ' Monat eintragen
Next InI
Cbo_Monat = Format(Date, "MMMM") ' Anzeige des aktuellen Monats, es wird der Kalender erstellt

With frm_Kalender_schön
' 0: Manuell;
' 1: Fenstermitte
' 2: Bildschirmmitte
' 3: Windows-Standard
' .StartUpPosition = 0 'links oben
.Top = 240
.Left = 480
' .Height = 250
.Width = 350
End With
' Stop

' frm_Kalender.Value = Date
' ActiveSheet.Range("J18") = (Calendar1.Value)
End Sub

Private Sub Cbo_Jahr_Change() ' Ereignis bei Änderung der Auswahl
If Cbo_Jahr.Tag = "" Then
Erstellen DateSerial(Cbo_Jahr, _
Cbo_Monat.ListIndex + 1, 1) ' Kalender erstellen
End If
End Sub

Private Sub Cbo_Monat_Change() ' Ereignis bei Änderung der Auswahl
If Cbo_Monat.Tag = "" Then
Erstellen DateSerial(Cbo_Jahr, _
Cbo_Monat.ListIndex + 1, 1) ' Kalender erstellen
End If
End Sub

Private Sub Scb_Monat_Change() ' Ereignis bei Veränderung
If Scb_Monat.Tag = "" Then
Erstellen DateSerial(1900 + Val(Scb_Monat / 12), Scb_Monat - _
Val(Scb_Monat / 12) * 12, 1) ' Kalender erstellen
End If
End Sub

und

Option Explicit

Dim Labels(9 To 50) As New clsDays

Private Sub cboMonths_Change()
Call SetFormValues
End Sub

Private Sub cboYears_Change()
Call SetFormValues
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdClipBoard_Click()
Dim ClipAbLage As DataObject
Dim iLabel As Integer
Dim sTxt As String

Set ClipAbLage = New DataObject

For iLabel = 9 To 50
If Controls("Label" & iLabel).BackColor = vbCyan Then
sTxt = Format(DateSerial(CInt(cboYears.Value), cboMonths.ListIndex + 1, CInt(Controls("Label" & iLabel).Caption)), "dd.MM.yyyy")
Exit For
End If
Next iLabel

If sTxt > "" Then
ClipAbLage.SetText sTxt
ClipAbLage.PutInClipboard
End If

Unload Me
End Sub

Private Sub cmdOK_Click()

Dim iLabel As Integer
For iLabel = 9 To 50
If Controls("Label" & iLabel).BackColor = vbCyan Then
ActiveSheet.Range("a4").Select
' frmCalendar.Value = ActiveSheet.Range("R11")
If Not ActiveCell Is Nothing Then ActiveCell.Value = DateSerial(CInt(cboYears.Value), cboMonths.ListIndex + 1, CInt(Controls("Label" & iLabel).Caption))

Exit For
End If
Next iLabel
Unload Me
End Sub

Public Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim iLabel As Integer
For iLabel = 9 To 50
If Controls("Label" & iLabel).BackColor = vbCyan Then

' MsgBox "www"
' ActiveSheet.Range("R11").Select
ActiveSheet.Range("a4").Select
' frmCalendar.Value = ActiveSheet.Range("R11")
If Not ActiveCell Is Nothing Then ActiveCell.Value = DateSerial(CInt(cboYears.Value), _
cboMonths.ListIndex + 1, CInt(Controls("Label" & iLabel).Caption))

Exit For
End If
Next iLabel
Unload Me
End Sub

Private Sub cmdWksCal_Click()
wksFeiertage.Range("j").Value = CInt(cboYears.Text)
Call CreatePersWks
End Sub

Private Sub lblML_Click()
If cboMonths.ListIndex = 0 Then
If cboYears.ListIndex > 1 Then
cboYears.ListIndex = cboYears.ListIndex - 1
cboMonths.ListIndex = 11
End If
Else
cboMonths.ListIndex = cboMonths.ListIndex - 1
End If
End Sub

Private Sub lblMR_Click()
If cboMonths.ListIndex = 11 Then
If cboYears.ListIndex cboYears.ListCount - 2 Then
cboYears.ListIndex = cboYears.ListIndex + 1
cboMonths.ListIndex = 0
End If
Else
cboMonths.ListIndex = cboMonths.ListIndex + 1
End If

End Sub

Private Sub lblYL_Click()
If cboYears.ListIndex > 0 Then cboYears.ListIndex = cboYears.ListIndex - 1
End Sub

Private Sub lblYR_Click()
If cboYears.ListIndex cboYears.ListCount - 2 Then cboYears.ListIndex = cboYears.ListIndex + 1
End Sub

Private Sub UserForm_Initialize()
Dim rng As Range
Dim datAct As Date
Dim vCaller As Variant, arr As Variant
Dim iCounter As Integer, iTop As Integer

datAct = Date

arr = Array("Mo", "Di", "Mi", "Do", "Fr", "Sa", "So")

For iCounter = 2 To 8
Controls("Label" & iCounter).Caption = arr(iCounter - 2)
Next iCounter

For iCounter = 1 To 12
cboMonths.AddItem Format(DateSerial(1, iCounter, 1), "mmmm")
Next iCounter

cboMonths.ListIndex = Month(datAct) - 1

For iCounter = 1900 To 2100
cboYears.AddItem iCounter
Next iCounter

cboYears.Value = Year(Date)
iTop = Controls("Label9").Top
For iCounter = 9 To 50
Set Labels(iCounter).LabelGroup = frmCalendar.Controls("Label" & iCounter)

Select Case iCounter
Case 16, 23, 30, 37, 44: iTop = iTop + Controls("Label9").Height
End Select

Controls("Label" & iCounter).Top = iTop
If Controls("Label" & iCounter).Caption = "" Then Controls("Label" & iCounter).Visible = False
Next iCounter

iTop = Controls("KW_1").Top
For iCounter = 1 To 6
Controls("KW_" & iCounter).Top = iTop
iTop = iTop + Controls("KW_1").Height
Next iCounter

End Sub

Private Sub SetFormValues()
Dim oCntr As Control
Dim rng As Range
Dim datAct As Date, dat As Date
Dim vCaller As Variant, vRow As Variant
Dim lDay As Long
Dim iLabel As Integer, iCounter As Integer, iDay As Integer
Dim sDay As String, wksFeiertage As Worksheet

Set wksFeiertage = Sheets("Feiertage")

If cboYears.Value = "" Then Exit Sub
wksFeiertage.Range("j1").Value = CInt(cboYears.Text)

datAct = Date

Controls("Label1").Caption = cboMonths.Value & " " & cboYears.Value
sDay = Format(DateSerial(cboYears.Value, cboMonths.ListIndex + 1, 1), "ddd")

For iLabel = 1 To 6
Controls("KW_" & iLabel).Caption = ""
Next iLabel

For iDay = 9 To 50
With Controls("Label" & iDay)
.Caption = ""
.BorderStyle = 0
.BackColor = &H8000000F
End With
Next iDay

For iLabel = 2 To 8
If Controls("Label" & iLabel).Caption = sDay Then Exit For
Next iLabel
iLabel = iLabel + 7

For lDay = DateSerial(cboYears.Value, cboMonths.ListIndex + 1, 1) To DateSerial(cboYears.Value, cboMonths.ListIndex + 2, 0)
iCounter = iCounter + 1

Controls("Label" & iLabel).Caption = iCounter
Controls("Label" & iLabel).BorderStyle = 0

Select Case iLabel
Case 9 To 15: Controls("KW_1").Caption = ISOWeek(CDate(lDay))
Case 16 To 22: Controls("KW_2").Caption = ISOWeek(CDate(lDay))
Case 23 To 29: Controls("KW_3").Caption = ISOWeek(CDate(lDay))
Case 30 To 36: Controls("KW_4").Caption = ISOWeek(CDate(lDay))
Case 37 To 43: Controls("KW_5").Caption = ISOWeek(CDate(lDay))
Case 44 To 50: Controls("KW_6").Caption = ISOWeek(CDate(lDay))
End Select

If CInt(cboYears.Value) = Year(datAct) And cboMonths.ListIndex + 1 = Month(datAct) And CInt(Controls("Label" & iLabel).Caption) = Day(datAct) Then
With Controls("Label" & iLabel)
.ForeColor = vbBlack
.BackColor = vbYellow
End With
End If

vRow = Application.Match(lDay, wksFeiertage.Columns(1), 0)
If Not IsError(vRow) Then

With Controls("Label" & iLabel)
.ForeColor = vbBlack
.BackColor = vbMagenta
.ControlTipText = WorksheetFunction.VLookup(lDay, wksFeiertage.Columns("A:B"), 2, 0)
End With
Else
Controls("Label" & iLabel).ControlTipText = ""
End If

iLabel = iLabel + 1
Next lDay

For Each oCntr In Controls
If TypeName(oCntr) = "Label" Then
If oCntr.Font.Name > "Wingdings" Then
oCntr.Font.Size = 8
oCntr.Font.Name = "Verdana"
End If
End If
Next oCntr

Call ResetControls
End Sub

Sub ResetControls()
Dim iAct As Integer

For iAct = 2 To 8
Controls("Label" & iAct).BackColor = 12224873
Controls("Label" & iAct).ForeColor = 15655385
Next iAct

For iAct = 1 To 6
Controls("KW_" & iAct).BackColor = 3969653
Controls("KW_" & iAct).ForeColor = 14545386

If Controls("KW_" & iAct).Caption = "" Then
Controls("KW_" & iAct).Visible = False
Else
Controls("KW_" & iAct).Visible = True
End If
Next iAct

For iAct = 9 To 50
If Controls("Label" & iAct).Caption = "" Then
Controls("Label" & iAct).Visible = False
Else
Controls("Label" & iAct).Visible = True
End If
Next iAct
End Sub

Private Function ISOWeek(dat As Date) As Integer
Dim dbl As Double
With WorksheetFunction
ISOWeek = Fix((dat - .Weekday(dat, 2) - _
DateSerial(Year(dat + 4 - _
.Weekday(dat, 2)), 1, -10)) / 7)
End With
End Function

sind das Problem!
Denn alle anderen spielen keine Rolle, denn ich habe Sie alle deaktiviert und ...
nun kommt die Frage (siehe Thread) Wahrscheinlich bin ich zu "klein" für solche Anfragen.

Egal, Du hast ein "Problem" und möchtest es gelöst haben.

Nun habe ich mir mal alle Dateien hier downgeloaded und von der ersten bis zu letzten fand ich, wurde wenig dargestellt. Es kann sein, dass Deine "Beantworter" mehr Infos haben

Hallo Charles, hast ja RECHT aber ich hatte doch schon --))

04.03.2025 13:41:28

sigrid

mit Doppelklick Datum setzen

Forumthread: mit Doppelklick Datum setzen

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

mit Doppelklick Datum setzen

Forumthread: mit Doppelklick Datum setzen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread