Fout 13

[t&d]

De code werkte eerst maar nu niet meer?
Ik denk dat het tussen regel 6 en 19 zit maar ben niet zeker.

Foutopsporing leid naar commandobutton, maar code is enkel om formulier te open

Private Sub cmdopen_2_Click()
    Userform1.Show
End Sub

 

Option Explicit
 
Dim blnNew As Boolean
Dim Dic As Object, i As Long
 
Private Sub UserForm_Initialize()
  
    cmdSave.Enabled = False
    Frame2.Enabled = False
    
Dim sv, i As Long
sv = Sheets(1).Cells(1).CurrentRegion
   Set Dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(sv)
      If Not Dic.exists(sv(i, 1)) Then Dic.Item(sv(i, 1)) = Array(sv(i, 1), CreateObject("scripting.dictionary"), CreateObject("scripting.dictionary"))
        Dic(sv(i, 1))(1).Item(sv(i, 2)) = Dic(sv(i, 1))(1).Item(sv(i, 2))
        Dic(sv(i, 1))(2).Item(sv(i, 2)) = Array(sv(i, 2), Application.Index(sv, i, Array(1, 3, 6, 7, 10, 11)), i)
    Next i
 ComboBox2.List = Dic.keys
 
 
Dim wb As Workbook: Set wb = ThisWorkbook
Dim WS As Worksheet
Dim LastRow As Long
Dim aCell As Range
 
Set WS = wb.Sheets("Type data")
 
With WS
    LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    
    For Each aCell In .Range("C1:C" & LastRow)
        If aCell.Value <> "" Then
            Me.TextBox2.AddItem aCell.Value
        End If
    Next
End With
 
 
 
Set WS = wb.Sheets("Type data")
 
With WS
    LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
    
    For Each aCell In .Range("O1:O" & LastRow)
        If aCell.Value <> "" Then
            Me.TextBox5.AddItem aCell.Value
        End If
    Next
End With
End Sub
 
Private Sub cmdClose_Click()
    If cmdClose.Caption = "Close" Then
        Unload Me
    Else
        cmdClose.Caption = "Close"
        cmdNew.Enabled = True
        
        
    End If
End Sub
 
Private Sub cmdNew_Click()
    blnNew = True
    txtklant.Text = ""
    txttype.Text = ""
    txtdossier.Text = ""
    txtdatum.Text = ""
    txtbestand.Text = ""
    txtbestemming.Text = ""
    
    cmdClose.Caption = "Cancel"
    cmdNew.Enabled = False
    cmdSave.Enabled = True
    Frame2.Enabled = True
End Sub
 
Private Sub cmdSave_Click()
    If Trim(txtklant.Text) = "" Then
        MsgBox "Enter klant", vbCritical, "Save"
        txtklant.SetFocus
        Exit Sub
    End If
    Call prSave
    cmdClose.Caption = "Close"
    cmdNew.Enabled = True
    ThisWorkbook.Save
    
End Sub
Private Sub prSave()
     ''''' Save the dms
    If blnNew = True Then
        TRows = Worksheets("dms").Range("A1").CurrentRegion.Rows.Count
        With Worksheets("dms").Range("A1")
            .Offset(TRows, 0).Value = txtklant.Text
            .Offset(TRows, 1).Value = txttype.Text
            .Offset(TRows, 2).Value = txtdossier.Text
            .Offset(TRows, 3).Value = txtdatum.Text
            .Offset(TRows, 4).Value = txtbestand.Text
            .Offset(TRows, 11).Value = txtbestemming.Text
         End With
            txtklant.Text = ""
            txttype.Text = ""
            txtdossier.Text = ""
            txtdatum.Text = ""
            txtbestand.Text = ""
            txtbestemming.Text = ""
            Call prComboBoxFill
     Else
        For i = 2 To TRows
            If Trim(Worksheets("dms").Cells(i, 1).Value) = Trim(ComboBox3.Text) Then
                Worksheets("dms").Cells(i, 1).Value = txtklant.Text
                Worksheets("dms").Cells(i, 2).Value = txttype.Text
                Worksheets("dms").Cells(i, 3).Value = txtdossier.Text
                Worksheets("dms").Cells(i, 4).Value = txtdatum.Text
                Worksheets("dms").Cells(i, 5).Value = txtbestand.Text
                Worksheets("dms").Cells(i, 13).Value = txtbestemming.Text
                txtklant.Text = ""
                txttype.Text = ""
                txtdossier.Text = ""
                txtdatum.Text = ""
                txtbestand.Text = ""
                txtbestemming.Text = ""
                Exit For
            End If
        Next i
      End If
    blnNew = False
    
    If Trim(txtklant.Text) = "" Then
        cmdSave.Enabled = False
        Frame2.Enabled = False
    Else
        cmdSave.Enabled = True
        Frame2.Enabled = True
    End If
End Sub
 
Private Sub cmdSearch_Click()
 Userform1.Show
End Sub
 
Private Sub ComboBox2_Change()
 hsv
 ComboBox3.List = Dic(ComboBox2.Value)(1).keys
 ComboBox3.ListIndex = -1
End Sub
 
 
Private Sub ComboBox3_Change()
If ComboBox3.ListIndex > -1 Then
  For i = 1 To 6
         Controls("Textbox" & i).Value = Dic(ComboBox2.Value)(2)(ComboBox3.Value)(1)(i)
     
  Next i
 End If
End Sub
 
Private Sub hsv()
ComboBox3.ListIndex = -1
For i = 1 To 6
   Me.Controls("TextBox" & i).Value = ""
 Next i
End Sub
 
 
Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
 
End Sub
 
Private Sub Image2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
 
End Sub

 

test_DMS.xlsm

[kweezie wabbit]

1 uur geleden, dotchiejack zei:

Eerst een opmerking, ik heb je vraag op Helpmij gezien.

Het gaat om dit topic: https://www.helpmij.nl/forum/showthread.php/944775-Foutmelding-13

 

We sluiten dan ook het topic hier af.