Thema Datum  Von Nutzer Rating
Antwort
20.08.2024 09:41:43 Max
NotSolved
20.08.2024 12:02:28 ralf_b
NotSolved
20.08.2024 12:48:41 max
NotSolved
20.08.2024 14:24:34 Alwin Weisangler
NotSolved
20.08.2024 15:27:35 Max
Solved
20.08.2024 20:17:07 ralf_b
NotSolved
20.08.2024 21:45:53 Gast23786
NotSolved
21.08.2024 08:46:28 Max
NotSolved
21.08.2024 10:18:37 Alwin Weisangler
NotSolved
21.08.2024 11:29:17 Max
NotSolved
21.08.2024 12:26:55 Alwin Weisangler
NotSolved
21.08.2024 12:45:06 Max
NotSolved
21.08.2024 14:28:10 Alwin Weisangler
NotSolved
21.08.2024 14:56:10 Max
NotSolved
21.08.2024 15:09:21 Max
NotSolved
21.08.2024 15:15:14 Gast12711
NotSolved
21.08.2024 15:27:48 Max
NotSolved
21.08.2024 15:37:26 Gast12979
NotSolved
21.08.2024 15:50:19 Alwin Weisangler
NotSolved
21.08.2024 15:55:46 Max
NotSolved
21.08.2024 15:55:55 Alwin Weisangler
NotSolved
Blau Laufzeitfehler 380
21.08.2024 22:39:20 Alwin Weisangler
NotSolved
22.08.2024 07:14:35 Max
NotSolved
22.08.2024 09:12:08 Gast1498
NotSolved
22.08.2024 10:26:50 Max
NotSolved
22.08.2024 10:54:11 Alwin Weisangler
NotSolved
22.08.2024 10:54:54 Gast67998
NotSolved
22.08.2024 11:10:10 Alwin Weisangler
NotSolved
22.08.2024 13:36:06 Max
NotSolved
22.08.2024 14:02:11 ralf_b
NotSolved
22.08.2024 14:14:11 Max
NotSolved
22.08.2024 18:19:46 Alwin Weisangler
Solved

Ansicht des Beitrags:
Von:
Alwin Weisangler
Datum:
21.08.2024 22:39:20
Views:
105
Rating: Antwort:
  Ja
Thema:
Laufzeitfehler 380

Hallo Max,

kompletter Code ins Modul des UserForm_AuditprogrammNeu:

Option Explicit
    Private arrList(), arrChk(), arrSpZuordnung, arrControls()

Private Sub Vorgaben()
    arrSpZuordnung = Array(1, 1, 11, 6, 2, 3, 9, 10, 4, 5, 7, 8)    ' Zuordnung der Tabellenspalten zu den Spalten der Listbox 1. Wert steht für Zeilennummer im Listobjekt und ist fix
    arrChk = Array("chkISO14001", "chkISO45001", "chkISO50001", "chkISO90001")  ' Checkboxen
    arrControls = Array("TxtAuditID", "cboAuditType", "txtPersonDays", "txtShift", "cboWerk", "txtCustomer", "txtResponsible", "txtLeadAuditor", "txtCoAuditor", "cboStatus")   ' Comboboxen /Textboxen
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)  ' Iso Nummern zuweisen
        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 ' Audit ID erzeugen
            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") ' Beispielhafte Auditarten
End Sub

' *********** Hilfsprozeduren ***********
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

Ich hoffe ich habe alles Erforderliche vollständig erwischt. Eine elementare Fehlerbehandlung ist drin und natürlich ganz ohne On Error.

Gruß Uwe


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
20.08.2024 09:41:43 Max
NotSolved
20.08.2024 12:02:28 ralf_b
NotSolved
20.08.2024 12:48:41 max
NotSolved
20.08.2024 14:24:34 Alwin Weisangler
NotSolved
20.08.2024 15:27:35 Max
Solved
20.08.2024 20:17:07 ralf_b
NotSolved
20.08.2024 21:45:53 Gast23786
NotSolved
21.08.2024 08:46:28 Max
NotSolved
21.08.2024 10:18:37 Alwin Weisangler
NotSolved
21.08.2024 11:29:17 Max
NotSolved
21.08.2024 12:26:55 Alwin Weisangler
NotSolved
21.08.2024 12:45:06 Max
NotSolved
21.08.2024 14:28:10 Alwin Weisangler
NotSolved
21.08.2024 14:56:10 Max
NotSolved
21.08.2024 15:09:21 Max
NotSolved
21.08.2024 15:15:14 Gast12711
NotSolved
21.08.2024 15:27:48 Max
NotSolved
21.08.2024 15:37:26 Gast12979
NotSolved
21.08.2024 15:50:19 Alwin Weisangler
NotSolved
21.08.2024 15:55:46 Max
NotSolved
21.08.2024 15:55:55 Alwin Weisangler
NotSolved
Blau Laufzeitfehler 380
21.08.2024 22:39:20 Alwin Weisangler
NotSolved
22.08.2024 07:14:35 Max
NotSolved
22.08.2024 09:12:08 Gast1498
NotSolved
22.08.2024 10:26:50 Max
NotSolved
22.08.2024 10:54:11 Alwin Weisangler
NotSolved
22.08.2024 10:54:54 Gast67998
NotSolved
22.08.2024 11:10:10 Alwin Weisangler
NotSolved
22.08.2024 13:36:06 Max
NotSolved
22.08.2024 14:02:11 ralf_b
NotSolved
22.08.2024 14:14:11 Max
NotSolved
22.08.2024 18:19:46 Alwin Weisangler
Solved