VBA-Beispiel 126
mail schreiben
mail schreiben

Zelleingaben über eine UserForm

Über eine UserForm sollen Eingaben in einen Monatskalender erfolgen.

Der Monat wird in Zelle A1 eingegeben. Die Anzeige der Tage passt sich entsprechend an.
Wochenenden werden farblich hervorgehoben, überzählige Tage (Februar) abgeschnitten.

Nach Aufruf der UserForm kann optional Zeile, Spalte oder beides ausgefüllt werden.
Demo für Anwesenheitsliste, Schichtplan oder ähnliches.

Bild der UserForm
Private lngZeile As Long, lngLZ As Long
Private intSpalte As Integer, intLS As Integer
'

Private Sub UserForm_Initialize()
Dim d As Date

wksMonat.Activate

d = Cells(1, 1)

'Anzahl der Tage des Monats in A1
intLS = DateSerial(Year(d), Month(d) + 1, 1) - DateSerial(Year(d), Month(d), 1) + 1

'intLS = Cells(1, Columns.Count).End(xlToLeft).Column
lngLZ = Cells(Rows.Count, 1).End(xlUp).Row - 2

'---------------------------------------------------------
'damit gleich kein Fehler entsteht, muss der Cursor
'im Datenbereich stehen
If ActiveCell.Row < 3 Or ActiveCell.Row > lngLZ Then
  Cells(5, 8).Activate
End If
If ActiveCell.Column < 2 Or ActiveCell.Column > intLS Then
  Cells(5, 8).Activate
End If
'---------------------------------------------------------

'Datum aus Zeile 1 auslesen bis letzte Spalte mit Inhalt
'und in comboDatum eintragen:
For intSpalte = 2 To intLS
  frmEingabe.comboDatum.AddItem (Cells(1, intSpalte))
Next intSpalte

'Spalte A auslesen bis letzte Zeile mit Inhalt
'und in comboUhrzeit eintragen:
For lngZeile = 3 To lngLZ
  frmEingabe.comboUhrzeit.AddItem Format((Cells(lngZeile, 1)), "hh:mm")
Next lngZeile

With frmEingabe
  .comboDatum.ListIndex = ActiveCell.Column - 2
  .comboUhrzeit.ListIndex = ActiveCell.Row - 3
  .txtEingabe.Text = "A"
  .cmbEntfernen.Enabled = False
  .chbSofort = Range("AI1")
  .chbZeile = Range("AI2")
  .chbSpalte = Range("AI3")
End With

If Me.chbSofort.Value = True Then
  Me.cmbEingabe.Enabled = False
Else
  Me.cmbEingabe.Enabled = True
End If

Call Farbe

End Sub

Private Sub chbSofort_Click()
  If Me.chbSofort.Value = True Then
    Me.cmbEingabe.Enabled = False
  Else
    Me.cmbEingabe.Enabled = True
  End If

  Call Farbe
End Sub

Private Sub chbSpalte_Click()
  Call Farbe
  cmbEntfernen.Enabled = True
End Sub
Private Sub chbZeile_Click()
  Call Farbe
  cmbEntfernen.Enabled = True
End Sub

Private Sub txtEingabe_Change()
  If txtEingabe.Value = "" Then
    cmbEingabe.Enabled = False
  Else
    cmbEingabe.Enabled = True
  End If
End Sub

Private Sub Farbe()

On Error GoTo Fehler

wksMonat.Unprotect
  If Me.Visible = True Then
    Range("AI1") = Me.chbSofort
    Range("AI2") = Me.chbZeile
    Range("AI3") = Me.chbSpalte
  End If

  Range(Cells(3, 2), Cells(lngLZ, intLS)).Interior.ColorIndex = xlNone

  'ganze Zeile
  If chbZeile.Value = True Then
    Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)).Interior.ColorIndex = 35
  End If

  'ganze Spalte
  If chbSpalte.Value = True Then
    Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)).Interior.ColorIndex = 35
  End If

wksMonat.Protect
Exit Sub

Fehler:
  MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine & _
         "Beschreibung: " & Err.Description, vbCritical, "Fehler"
End Sub

Private Sub comboDatum_Change()
  intSpalte = comboDatum.ListIndex + 2
  Call ZelleZeigen
End Sub

Private Sub comboUhrzeit_Change()
  lngZeile = comboUhrzeit.ListIndex + 3
  Call ZelleZeigen
End Sub

Private Sub ZelleZeigen()

If frmEingabe.Visible = True Then
  Call Farbe
  Cells(lngZeile, intSpalte).Select

  If chbSofort.Value = True Then

    'ganze Zeile ausfüllen
    If chbZeile.Value = True Then
      Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)) = txtEingabe
    End If
    'ganze Spalte ausfüllen
    If chbSpalte.Value = True Then
      Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)) = txtEingabe
    End If

    Cells(lngZeile, intSpalte) = txtEingabe
  End If

  cmbEntfernen.Enabled = True
End If

End Sub

Private Sub cmbEntfernen_Click()

wksMonat.Unprotect

If chbZeile.Value = True Then
  Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)) = ""
  Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)).Interior.ColorIndex = 15
End If

If chbSpalte.Value = True Then
  Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)) = ""
  Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)).Interior.ColorIndex = 15
End If

wksMonat.Protect

If ActiveCell.Value <> "" Then
  ActiveCell = ""
End If

cmbEntfernen.Enabled = False
End Sub
Private Sub cmbEingabe_Click()

On Error GoTo Fehler

wksMonat.Unprotect
  'ganze Zeile ausfüllen
  If chbZeile.Value = True Then
    Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)) = txtEingabe
    Range(Cells(lngZeile, 2), Cells(lngZeile, intLS)).Interior.ColorIndex = 35
  End If
  'ganze Spalte ausfüllen
  If chbSpalte.Value = True Then
    Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)) = txtEingabe
    Range(Cells(3, intSpalte), Cells(lngLZ, intSpalte)).Interior.ColorIndex = 35
  End If

ActiveCell.Interior.ColorIndex = 35
wksMonat.Protect

Cells(comboUhrzeit.ListIndex + 3, comboDatum.ListIndex + 2) = txtEingabe
cmbEntfernen.Enabled = True
Exit Sub

Fehler:
  MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine & _
         "Beschreibung: " & Err.Description, vbCritical, "Fehler"
End Sub

Private Sub cmbCancel_Click()
  Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, _
                             CloseMode As Integer)
  wksMonat.Unprotect

  'wg Demo Daten am Ende immer löschen
  With Range(Cells(3, 2), Cells(lngLZ, intLS))
    .Interior.ColorIndex = xlNone
    .Cells = ""
  End With

  wksMonat.Protect
End Sub


Download:   vba126.zip