Option Explicit
Private arrList(), arrChk(), arrSpZuordnung, arrControls()
Private Sub Vorgaben()
arrSpZuordnung = Array(1, 1, 11, 6, 2, 3, 9, 10, 4, 5, 7, 8)
arrChk = Array("chkISO14001", "chkISO45001", "chkISO50001", "chkISO90001")
arrControls = Array("TxtAuditID", "cboAuditType", "txtPersonDays", "txtShift", "cboWerk", "txtCustomer", "txtResponsible", "txtLeadAuditor", "txtCoAuditor", "cboStatus")
End Sub
Private Sub ListboxLaden()
Dim arrTab(), i&
With Tabelle7.ListObjects(1)
If .DataBodyRange Is Nothing Then lstAudits.Clear: Exit Sub
arrTab = .DataBodyRange.Value
If .ListRows.Count > 1 Then
arrList = Application.Index(arrTab, Evaluate("row(1:" & UBound(arrTab, 1) & ")"), arrSpZuordnung)
For i = 1 To UBound(arrList)
arrList(i, 1) = i
Next i
Else
ReDim arrList(1 To 1, 1 To .ListColumns.Count + 1)
arrList(1, 1) = 1
For i = 2 To UBound(arrList, 2)
arrList(1, i) = arrTab(1, arrSpZuordnung(i - 1))
Next i
End If
End With
With lstAudits
.ColumnCount = UBound(arrList, 2)
.List = arrList
.ColumnWidths = "0;50;70;200;60;200;100;100;25;50;100;0"
End With
End Sub
Private Sub Cmd_Aendern_Click()
Dim i&, strIso$, iZeile&, zWerk As Variant, arrZeile(1 To 1, 1 To 11)
If lstAudits.ListIndex = -1 Then MsgBox "Kein Eintrag ausgewählt.", vbInformation, "Schreiben nicht möglich": Exit Sub
iZeile = lstAudits.List(lstAudits.ListIndex, 0)
For i = 0 To 3
If Controls(arrChk(i)) = True Then strIso = strIso & "ISO " & Right(arrChk(i), 5) & ", "
Next i
With Tabelle7.ListObjects(1).DataBodyRange
For i = 0 To 1
arrZeile(1, i + 1) = Controls(arrControls(i))
Next i
For i = 2 To UBound(arrControls)
arrZeile(1, i + 2) = Controls(arrControls(i))
Next i
If strIso <> "" Then arrZeile(1, 3) = Left(strIso, Len(strIso) - 2)
.Cells(iZeile, 1).Resize(UBound(arrZeile, 1), UBound(arrZeile, 2)) = arrZeile
End With
If lstAudits.List(lstAudits.ListIndex, 1) = "" Then
zWerk = Application.Match(cboWerk, Tabelle0.Range("Tabelle2[Werkname]"), 0)
If Not IsError(zWerk) Then
Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) = Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) + 1
End If
End If
ListboxLaden
ControlsLeeren
End Sub
Private Sub Cmd_Beenden_Click()
Unload Me
End Sub
Private Sub Cmd_Delete_Click()
Dim iZeile&, zWerk As Variant
If lstAudits.ListIndex = -1 Then MsgBox "Kein Eintrag ausgewählt.", vbInformation, "Löschen nicht möglich": Exit Sub
iZeile = lstAudits.List(lstAudits.ListIndex, 0)
zWerk = Application.Match(cboWerk, Tabelle0.Range("Tabelle2[Werkname]"), 0)
If MsgBox("Soll der Eintrag gelöscht werden?", vbQuestion + vbYesNo, "Abfrage Löschen eines Eintrages") = vbYes Then
Tabelle7.ListObjects(1).ListRows(iZeile).Delete
lstAudits.RemoveItem (lstAudits.ListIndex)
Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) = Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) - 1
End If
ListboxLaden
ControlsLeeren
End Sub
Private Sub Cmd_NeuerEintrag_Click()
Dim i&, zWerk As Variant, strIso$, arrZeile(1 To 1, 1 To 11)
zWerk = Application.Match(cboWerk, Tabelle0.Range("Tabelle2[Werkname]"), 0)
If Not IsError(zWerk) Then
TxtAuditID = Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 1) & "-" & Format(Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4), "00") + 1
Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) = Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4) + 1
End If
For i = 0 To 1
arrZeile(1, i + 1) = Controls(arrControls(i))
Next i
For i = 2 To UBound(arrControls)
arrZeile(1, i + 2) = Controls(arrControls(i))
Next i
For i = 0 To 3
If Controls(arrChk(i)) = True Then strIso = strIso & "ISO " & Right(arrChk(i), 5) & ", "
Next i
If strIso <> "" Then arrZeile(1, 3) = Left(strIso, Len(strIso) - 2)
Tabelle7.ListObjects(1).ListRows.Add.Range.Resize(UBound(arrZeile, 1), UBound(arrZeile, 2)) = arrZeile
ListboxLaden
ControlsLeeren
End Sub
Private Sub lstAudits_Click()
Dim tmp, i&, zWerk As Variant
With lstAudits
TxtAuditID = .List(.ListIndex, 1)
cboStatus = .List(.ListIndex, 2)
cboWerk = .List(.ListIndex, 3)
cboAuditType = .List(.ListIndex, 4)
txtLeadAuditor = .List(.ListIndex, 6)
txtCoAuditor = .List(.ListIndex, 7)
txtPersonDays = .List(.ListIndex, 8)
txtShift = .List(.ListIndex, 9)
txtCustomer = .List(.ListIndex, 10)
txtResponsible = .List(.ListIndex, 11)
tmp = .List(.ListIndex, 5)
For i = 0 To UBound(arrChk)
If InStr(1, tmp, Right(arrChk(i), 5), vbTextCompare) > 0 Then
Controls(arrChk(i)) = True
Else
Controls(arrChk(i)) = False
End If
Next i
If TxtAuditID = "" Then
zWerk = Application.Match(.List(.ListIndex, 3), Tabelle0.Range("Tabelle2[Werkname]"), 0)
If Not IsError(zWerk) Then
TxtAuditID = Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 1) & "-" & Format(Tabelle0.ListObjects(1).DataBodyRange.Cells(zWerk, 4), "00") + 1
End If
End If
End With
End Sub
Private Sub UserForm_Initialize()
Vorgaben
ListboxLaden
cboWerk.List = Tabelle0.Range("Tabelle2[Werkname]").Value
cboStatus.List = Array("Offen", "In Bearbeitung", "Abgeschlossen")
cboAuditType.List = Array("Intern", "Extern", "Kundenaudit", "Systemaudit")
End Sub
Private Sub ControlsLeeren()
Dim objControl As Control
For Each objControl In Controls
Select Case TypeName(objControl)
Case "TextBox"
objControl.Text = ""
Case "ComboBox"
objControl.ListIndex = -1: objControl = ""
Case "CheckBox"
objControl.Value = False
End Select
Next
lstAudits.ListIndex = -1
End Sub