Hallo Peter,
na wirklich viel gibt es da nicht zu erklären, anbei der Code mit ein paar Kommentaren.
' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************
Option Explicit
Private Sub cboKS_Change()
setData
End Sub
Private Sub cboYear_Change()
Dim lngI As Long
cboDB1.Clear
cboDB1 = ""
cboDB2.Clear
cboDB2 = ""
'Datum vom 1.1. bis 31.12. in Combobox eintragen
For lngI = 1 To DateSerial(cboYear, 12, 31) - DateSerial(cboYear, 1, 1) + 1
cboDB1.AddItem Format(DateSerial(cboYear, 1, lngI))
Next
'Liste aus 1. Combobox in zweite übertragen
cboDB2.List = cboDB1.List
setData
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdEntry_Click()
Dim vntRet As Variant, vntRow As Variant
'Daten eintragen
On Error Resume Next
With ActiveSheet
vntRet = Application.Match(Clng(cboYear), .Rows(2), 0) 'Jahr finden
If IsNumeric(vntRet) Then
vntRow = Application.Match(Clng(cboKS), Columns(1), 0) 'KS finden
If IsNumeric(vntRow) Then
'Daten eintragen wenn Eintrag in TextBox/Combobox vorhanden
If Len(txtNB1) Then .Cells(vntRow, vntRet) = txtNB1 / 100 Else: .Cells(vntRow, vntRet) = ""
If Len(txtNB2) Then .Cells(vntRow, vntRet + 1) = txtNB2 / 100 Else: .Cells(vntRow, vntRet + 1) = ""
If Len(cboVB1) Then .Cells(vntRow, vntRet + 2) = cboVB1 Else: .Cells(vntRow, vntRet + 2) = ""
If Len(cboVB2) Then .Cells(vntRow, vntRet + 3) = cboVB2 Else: .Cells(vntRow, vntRet + 3) = ""
If Len(cboDB1) Then .Cells(vntRow, vntRet + 4) = CDate(cboDB1) Else: .Cells(vntRow, vntRet + 4) = ""
If Len(cboDB2) Then .Cells(vntRow, vntRet + 5) = CDate(cboDB2) Else: .Cells(vntRow, vntRet + 5) = ""
End If
End If
End With
End Sub
Private Sub txtNB1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Nur Zahlen 0-9 und max 100 zulassen
Select Case KeyAscii
Case 47 To 58
If Len(txtNB1) > 2 Then KeyAscii = 0
If Clng(txtNB1 & "0") > 100 Then txtNB1 = "100"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub txtNB2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Nur Zahlen 0-9 und max 100 zulassen
Select Case KeyAscii
Case 47 To 58
If Len(txtNB2) > 2 Then KeyAscii = 0
If Clng(txtNB2 & "0") > 100 Then txtNB2 = "100"
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub UserForm_Activate()
Dim lngYear As Long, vntTmp As Variant, vntList As Variant
Dim lngI As Long
With ActiveSheet
'Jahres-Combobox füllen
For lngYear = Application.Min(.Rows(2)) To Application.Max(.Rows(2))
cboYear.AddItem CStr(lngYear)
Next
cboYear = Year(Date)
'KS in Array speichern (Spalte A)
vntTmp = .Range("A5:A" & Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row))
'Liste bereinigen und sortieren
vntList = toArraySorted(vntTmp)
cboKS.ListRows = 20
cboKS.List = vntList 'Liste zuweisen
'Berwertungs-Boxen füllen
cboVB1.List = Array("", "1", "2", "3", "3+")
cboVB2.List = Array("", "1", "2", "3", "3+")
'datumsboxen füllen
For lngI = 1 To DateSerial(cboYear, 12, 31) - DateSerial(cboYear, 1, 1) + 1
cboDB1.AddItem Format(DateSerial(cboYear, 1, lngI))
Next
cboDB1.ListRows = 20
cboDB2.ListRows = 20
cboDB2.List = cboDB1.List
End With
setData
End Sub
Private Sub setData()
Dim vntRet As Variant, vntRow As Variant
'Daten aktualiesieren
On Error Resume Next
With ActiveSheet
vntRet = Application.Match(Clng(cboYear), .Rows(2), 0) 'Jahr suchen
If IsNumeric(vntRet) Then
vntRow = Application.Match(Clng(cboKS), Columns(1), 0) 'KS suchen
If IsNumeric(vntRow) Then
txtNB1 = Replace(.Cells(vntRow, vntRet).Text, "%", "")
txtNB2 = Replace(.Cells(vntRow, vntRet + 1).Text, "%", "")
cboVB1 = .Cells(vntRow, vntRet + 2).Text
cboVB2 = .Cells(vntRow, vntRet + 3).Text
cboDB1 = .Cells(vntRow, vntRet + 4)
cboDB2 = .Cells(vntRow, vntRet + 5)
End If
End If
End With
End Sub
'Funktion um Array zu bereinigen (doppler) und zu sortieren
Private Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = LBound(Field, 1) To UBound(Field, 1)
For lngC = LBound(Field, 2) To UBound(Field, 2)
If Not .Contains(Trim(Field(lngR, lngC))) Or Not Uniqe Then
If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
End If
Next
Next
.Sort
toArraySorted = .toArray
End With
Exit Function
ErrExit:
toArraySorted = -1
End Function
Gruß Sepp
