Userform met datafilter aanpassen

fmssll · 15 dec 2013

Hallo,

Ik heb een interessant databankje gevonden die via een userform data filtert m.b.v. 4 comboboxen uit columns A, B, C, D en plaatst waarden terug van columns E, F en G in een listbox en in 3 textboxen waar de data kan gewijzigd worden en via een commandbutton deze wijzigingen kan opgeslagen worden.

'K Had graag de code aangepast en uitgebreid naar:
filtert m.b.v. 5 comboboxen uit columns B, C, D, E, F en G (column A wordt niet gebruikt) en plaatst waarden terug van columns H, I, J, K, en L in 5 textboxen waar de data dan weer kan gewijzigd kan worden. Ook wil ik de code wijzigen zodat alle columns in de listbox worden getoond (B t.e.m L)

Bij iedere poging om de code aangepast te krijgen, wordt ik om de oren geslagen met foutmeldingen omtrent Array.
Het is niet de bedoeling dat U de code aanpast naar mijn wensen, maar door de essentiële macro's aan te duiden en een kleine uitleg 'waarom' mij in de juiste richting te sturen.

code in Useform:

Code:

Option Explicit

Private Sub cboName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    KeyCode = 0
End Sub

Code:

Private Sub cboParts_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    KeyCode = 0
End Sub

Code:

Private Sub cboRegion_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    KeyCode = 0
End Sub

Code:

Private Sub cboType_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    KeyCode = 0
End Sub

Code:

Private Sub cmdClose_Click()
    Unload Me
End Sub

Code:

Private Sub cmdReset_Click()
    Dim ctrl As Control
    ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter
    For Each ctrl In Me.Controls
        If StrComp(TypeName(ctrl), "combobox", vbTextCompare) = 0 Or StrComp(TypeName(ctrl), "listbox", vbTextCompare) = 0 Then
            ctrl.Clear
            ctrl.Enabled = False
        ElseIf StrComp(TypeName(ctrl), "textbox", vbTextCompare) = 0 Then
            ctrl.Value = vbNullString
            ctrl.Enabled = False
        End If
    Next ctrl
    
    Fill_Cbo Me.cboRegion, 1
    Fill_List
    Me.cboRegion.Enabled = True
End Sub

Code:

Private Sub cmdSave_Click()
    Dim xlRng As Range
    Dim sAddr As String
    Dim i As Integer
    On Error GoTo cmdSave_Click_ErrorHandler

    With Me.lstList
        For i = 0 To .ListCount
            If .Selected(i) Then
                With ThisWorkbook.Worksheets("Sheet1")
                    Set xlRng = .Columns(6).Find(What:=Me.lstList.List(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not xlRng Is Nothing Then
                        sAddr = xlRng.Address
                        Do
                            If xlRng.Offset(, -1).Value = Me.lstList.List(i, 0) And xlRng.Offset(, 1).Value = Me.lstList.List(i, 2) Then
                                .Range(xlRng.Offset(, -1), xlRng.Offset(, 1)).Value = Array(Me.txtDesc.Value, Me.txtCode.Value, Me.txtCom.Value)
                                MsgBox "Saved!"
                                Fill_List
                                GoTo cmdSave_Click_Proc_Exit
                            End If
                            Set xlRng = .Columns(1).FindNext(xlRng)
                        Loop While Not xlRng Is Nothing And xlRng.Address <> sAddr
                        Err.Raise vbObjectError + 512, , "Match not found."
                    Else
                        Err.Raise vbObjectError + 512, , "PROD CODE not found."
                    End If
                End With
            End If
        Next i
    End With

cmdSave_Click_Proc_Exit:
    Exit Sub
cmdSave_Click_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'cmdSave_Click' of Form 'UserForm1'.", vbOKOnly + vbCritical, "Error"
    Resume cmdSave_Click_Proc_Exit
End Sub

Code:

Private Sub lstList_Click()
    Dim i As Integer
    With Me.lstList
        For i = 0 To .ListCount
            If .Selected(i) Then
                Me.txtDesc.Value = .List(i, 0)
                Me.txtCode.Value = .List(i, 1)
                Me.txtCom.Value = .List(i, 2)
                Exit For
            End If
        Next i
    End With
End Sub

Code:

Private Sub UserForm_Initialize()
    Application.ScreenUpdating = False
    ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter
    Fill_Cbo Me.cboRegion, 1
    Me.cboRegion.Enabled = True
End Sub

Code:

Private Sub cboRegion_Change()
    ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter
    If Me.cboRegion.Value <> vbNullString Then
        ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter Field:=1, Criteria1:=Me.cboRegion.Value
        Fill_Cbo Me.cboName, 2
        Fill_Cbo Me.cboParts, 3
        Fill_Cbo Me.cboType, 4
        Fill_List
        Me.txtCode.Enabled = True
        Me.txtCom.Enabled = True
        Me.txtDesc.Enabled = True
    End If
End Sub

Code:

Private Sub cboName_Change()
    If Me.cboName.Value <> vbNullString Then
        ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter Field:=2, Criteria1:=Me.cboName.Value
        Fill_Cbo Me.cboParts, 3
        Fill_Cbo Me.cboType, 4
        Fill_List
    End If
End Sub

Code:

Private Sub cboParts_Change()
    If Me.cboParts.Value <> vbNullString Then
        ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter Field:=3, Criteria1:=Me.cboParts.Value
        Fill_Cbo Me.cboType, 4
        Fill_List
    End If
End Sub

Code:

Private Sub cboType_Change()
    If Me.cboType.Value <> vbNullString Then
        ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter Field:=4, Criteria1:=Me.cboType.Value
        Fill_List
        Me.txtCode.Enabled = True
        Me.txtCom.Enabled = True
        Me.txtDesc.Enabled = True
    End If
End Sub

Code:

Private Sub Fill_List()
    Dim xlRow As Range, xlRng As Range
    Dim aData, aCbos
    Dim blnValid As Boolean
    Dim i As Long, j As Integer
    
    On Error GoTo Fill_List_ErrorHandler

    aCbos = Array(Me.cboRegion, 1, Me.cboName, 2, Me.cboParts, 3, Me.cboType, 4)
    With ThisWorkbook
        With Worksheets("Sheet1")
            .UsedRange.AutoFilter
            For i = LBound(aCbos, 1) To UBound(aCbos, 1) Step 2
                If Trim(aCbos(i).Value) <> vbNullString Then
                    .UsedRange.AutoFilter Field:=aCbos(i + 1), Criteria1:=aCbos(i).Value
                    blnValid = True
                End If
            Next i
            If Not blnValid Then
                UserForm1.lstList.Clear
                GoTo Fill_List_Proc_Exit
            End If
            Set xlRng = .Cells(1, 1).CurrentRegion.Offset(1).Columns(1).SpecialCells(12)
        End With
    End With
    With UserForm1.lstList
        .Clear
        If xlRng.Cells.Count > 1 Then
            ReDim aData(1 To xlRng.Cells.Count, 1 To 3)
            .ColumnCount = 3: i = 1
            For Each xlRow In xlRng.Rows
                For j = 1 To 3
                    aData(i, j) = xlRow.Parent.Cells(xlRow.Row, j + 4).Value
                Next j
                i = i + 1
            Next xlRow
        Else
            
        End If
        .List = aData
    End With

Fill_List_Proc_Exit:
    Exit Sub
Fill_List_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'Fill_List' of Form 'UserForm1'.", vbOKOnly + vbCritical, "Error"
    Resume Fill_List_Proc_Exit
End Sub

Code:

Private Sub UserForm_Terminate()
    ThisWorkbook.Worksheets("Sheet1").UsedRange.AutoFilter
    Application.ScreenUpdating = True
End Sub

de code in een module:

Code:

Option Explicit
Option Compare Text

Sub QSort_1D(aArray, _
              Optional ByRef lngLBound As Long = 0, _
              Optional ByRef lngUBound As Long = 0)

    Dim vntTmp1 As Variant, vntTmp2 As Variant, lngLB As Long, lngUB As Long

    If lngLBound < LBound(aArray) Or lngLBound >= UBound(aArray) Then lngLBound = LBound(aArray)
    If lngUBound > UBound(aArray) Or lngUBound <= LBound(aArray) Then lngUBound = UBound(aArray)

    lngLB = lngLBound
    lngUB = lngUBound
    vntTmp2 = aArray((lngLBound + lngUBound) \ 2)
    Do While lngLB <= lngUB
        Do While aArray(lngLB) < vntTmp2 And lngLB < lngUBound: lngLB = lngLB + 1: Loop
        Do While vntTmp2 < aArray(lngUB) And lngUB > lngLBound: lngUB = lngUB - 1: Loop
        If lngLB <= lngUB Then
            vntTmp1 = aArray(lngLB): aArray(lngLB) = aArray(lngUB): aArray(lngUB) = vntTmp1: lngLB = lngLB + 1: lngUB = lngUB - 1
        End If
    Loop
    If lngLBound < lngUB Then QSort_1D aArray, lngLBound, lngUB
    If lngLB < lngUBound Then QSort_1D aArray, lngLB, lngUBound
End Sub

Sub Fill_Cbo(ByVal objControl As Control, iColSrc As Integer)
    Dim xlRng As Range, xlRow As Range, aData
    Dim i As Long, j As Long
    With ThisWorkbook
        With Worksheets("Sheet1")
            'fill comboboxes.
            Set xlRng = .Range(.Cells(2, iColSrc), .Cells(.Cells(.Rows.Count, iColSrc).End(xlUp).Row, iColSrc)).Columns(1).SpecialCells(12).Cells
            ReDim aData(xlRng.Cells.Count, 1 To 1)
            For Each xlRow In xlRng.Rows
                aData(i, 1) = .Cells(xlRow.Row, iColSrc).Value
                i = i + 1
            Next xlRow
            aData = PrepareCboList(aData)
            objControl.Clear
            If IsArray(aData) Then
                For i = LBound(aData, 1) To UBound(aData, 1)
                    objControl.AddItem aData(i)
                Next i
            Else
                objControl.AddItem aData
            End If
        End With
    End With
    objControl.Enabled = True
End Sub

Function PrepareCboList(aData) As Variant
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim dKey
    Dim i As Long
    If IsArray(aData) Then
        For i = LBound(aData, 1) To UBound(aData, 1)    'loop array
            If Not IsEmpty(aData(i, 1)) Then dic(aData(i, 1)) = 0        'store unique values
        Next i
        ReDim aData(1 To dic.Count): i = 1  'prepare array
        For Each dKey In dic.keys       'fill array
            aData(i) = dKey
            i = i + 1
        Next dKey
        'sort array
        QSort_1D aData
    End If
    'return sorted unique array
    PrepareCboList = aData
End Function

Alvast bedankt om tijd te nemen om mijn vraag te lezen.

huijb · 15 dec 2013

Voordat je verder gaat met berichten te plaatsen lees dit s.v.p. http://www.helpmij.nl/forum/showthr...-de-helpers-in-deze-sectie-van-dienst-te-zijn

fmssll · 16 dec 2013

OK, bedankt voor de reactie.
'k zal mijn vraag herwerken.

OctaFish · 16 dec 2013

Je zou ook alle code die niet terzake doet er uit kunnen gooien; nu ziet er een hoop onnodige code in je bericht. En daar moet je als helper toch doorheen, want hoe weet je anders dat het niets met het vraagstuk te maken heeft? Als je zelf dat onderscheid niet kunt maken, kun je veel beter het bestand meesturen, dan zien we de code daar vanzelf wel staan. Voorlopig ga ik even met mijn scrollarm in het ijs

Userform met datafilter aanpassen

fmssll

Nieuwe gebruiker

huijb

Supermoderator

fmssll

Nieuwe gebruiker

OctaFish

Verenigingslid

Nieuwste berichten

Wij waarderen jouw privacy