filtro su listbox mediante combobox

Question

Salve a tutti.

ho provato diverse soluzioni ma non sono riuscito nell'intento di collegare una combobox che mi filtri i valori di una listbox come nell'esempio allegato:

la procedura dovrebbe essere la seguente:

• la combobox1 legge i dati della tabella (prova) e aggiorna la listbox1
• digitando nella combobox1, parte o tutto del contenuto di una riga della colonna "B" della tabella "prova", premendo invio la listbox1 deve mostrare solo i record che soddisfano la condizione.
• digitando nuovamente nella combobox1 parte o tutto del contenuto di una riga della colonna "C" della tabella "prova", premendo invio la listbox1 deve mostrare solo i record che soddisfano la condizione.

sia dopo la fase a) oppure la fase b) si può con doppioclik sulla riga interessata della listbox1 riempire le textbox e lavorarci sopra (processo già funzionante).

file di esempio:

https://www.dropbox.com/s/ea2ys9352wjtmtc/FiltraDati.xlsm?dl=0

Grazie dell'aiuto

Answer 1

Ciao gio56,

Ritorno al thread così in ritardo rispetto ai tempi promessi e quindi permettimi che ne spieghi il motivo.

Inizialemente ho guardato il file trovato sul rete da te e, mentre non mi sembrava difficile adattarlo per gestire il tuo file, pensavo che molte delle operazioni di quel file avrebbero potuto essere eseguite in modo più efficiente e più pulito. Pertanto, ho deciso di creare un addin generico che avrebbe maggiore funzionalità e che potrebbe essere utilizzato con qualsiasi database, magari creando gli oggetti sulla userform a runtime.  Ho preso questa decisione anche perché mi è apparso che il tuo file di esempio è stato semplicemente un esempio generico di qualsiasi database multi-colonna del tipo flat file.

Come l'ho visualizzato io, questo componenete aggiuntivo eviterebbe l'uso di fogli di appoggio o gli strumenti di Excel. Inoltre, l'addin assicurerebbe sia velocità che efficienza, eseguendo tutte le azioni intermedie in memoria. Come ho progredito con questo progetto, mi sono venuto in mente anche altre caratteristiche desiderabili e ci sto lavorando per incorporale in modo organico nel progetto. 

Tuttavia, mi sono accorto, forse troppo tardi, che tu avrai dei vincoli di tempo per complerare il tuo progetto personale e quindi, quasi certamente, non vorresti aspettare più a lungo!  Pertanto, ho deciso di accantonare, temporaneamente, l'addin e, nel frattempo, adattare il file del rete alle tue esigenze.

Tornando quindi al file del rete, ho fatto le seguente modifiche:

• Ho aumentato il numero degli oggetti ComboBox  e Label per riflettare  il fatto che tu hai 24 colonne nel tuo file anzichè le 6 colonne del file di rete.
• Ho effettuato diverse modifiche al codice, le quale sono evidenziate in grassetto, Nota, però, che se io non fosse creando l'addin, avrei anche riscritto molto dell'altro codice!

Nel modulo standard il codice sarebbe:

'=========>>

Option Explicit

Public col, R_r, n, Old(), sh1 As Worksheet, sh2 As Worksheet

Public RngDati As Range

Public LCol As Long

'--------->>

Sub apri()

    UserForm1.Show vbModeless

End Sub

'--------->>

Sub SetFg()

Dim WB As Workbook

Dim LRow As Long

Set WB = ThisWorkbook

    With WB

        Set sh1 = .Sheets("Prova")    'Worksheets("Database")

        Set sh2 = **,**Worksheets("Appoggio")

    End With

  With sh1

LRow = LastRow(sh1, .Columns("A:A"))

LCol = LastCol(sh1, .Rows(1))

Set RngDati = .Range("A2").Resize(LRow - 1, LCol)

End With

End Sub

'--------->>

Sub setNo()

    Set sh1 = Nothing

    Set sh2 = Nothing

End Sub

'--------->>

Sub Indici()

    Dim r, c, x, y, cl, Rng, cbx As New Collection

    Dim k, j, Sw1, Sw2

    SetFg

    sh1.Activate

    r = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    c = 1

    For y = 1 To LCol     '6

        Set Rng = Range(sh1.Cells(2, y), sh1.Cells(r, y))

        On Error Resume Next

        For Each cl In Rng

            If Not IsError(cl) Then

                If cl <> "" Then cbx.Add cl.Value, CStr(cl.Value)

            End If

        Next cl

        On Error GoTo 0

        For k = 1 To cbx.Count - 1

            For j = k + 1 To cbx.Count

                If cbx(k) > cbx(j) Then

                    Sw1 = cbx(k)

                    Sw2 = cbx(j)

                    cbx.Add Sw1, before:=j

                    cbx.Add Sw2, before:=k

                    cbx.Remove k + 1

                    cbx.Remove j + 1

                End If

            Next j

        Next k

        With UserForm1.Controls("ComboBox" & y + 1)

            .Clear

            For x = 1 To cbx.Count

                .AddItem cbx(x)

            Next x

            .ListIndex = 0

        End With

        Set Rng = Nothing

        Set cbx = Nothing

        c = c + 1

    Next y

End Sub

'--------->>

Public Function FiCop1(Fp, rp, cop, cof, Fa, Ra, coa, cor, Cri)

    Dim vert

    On Error GoTo 1

    Application.ScreenUpdating = False

    Sheets(Fa).Select

    ActiveWindow.FreezePanes = False

    Cells.Select

    Selection.Delete Shift:=xlUp

    Cells(Ra, coa).Select

    Sheets(Fp).Select

    If Cells(rp + 1, cop) = "" Then

        MsgBox "Nessun dato da cercare", , "Controllo dati"

        Sheets(1).Select

        Exit Function

    End If

    vert = Cells(rp, cop).End(xlDown).Row

    Range(Cells(rp, cop), Cells(vert, cof)).Select

    Selection.AutoFilter

    Selection.AutoFilter Field:=cor, Criteria1:=Cri

    Selection.Copy

    Sheets(Fa).Select

    ActiveSheet.Paste

    If Cells(Ra + 1, coa) = "" Then

        'MsgBox "Nessun Dato da Visualizzare", , "Verifica dati"

        Sheets(Fp).Select

        Selection.AutoFilter

        Cells(rp, cop).Select

        Exit Function

    End If

    Sheets(Fa).Select

    Columns("A:AA").Select

    Selection.Columns.AutoFit

    Cells(Ra, coa).Select

    Sheets(Fp).Select

    Selection.AutoFilter

    Cells(rp, cop).Select

1:

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'--------->>

Public Function LastCol(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastCol = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByColumns, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Column

    On Error GoTo 0

End Function

'<<=========

Nel modulo do codice della Userform:

'=========>>

Option Explicit

'--------->>

Private Sub ComboBox1_AfterUpdate()

    Dim r, x, cl, Rng, cbx As New Collection

    If ComboBox1 = "" Or col > 4 Then Exit Sub

    r = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    Select Case col

    Case 1: Call FiCop1(sh1.Name, 1, 1, 6, sh2.Name, 1, 1, 1, ComboBox1): CommandButton2.Visible = True

    Case Else: Call FiCop1(sh1.Name, 1, 1, 6, sh2.Name, 1, 1, col, ComboBox1)

    End Select

    sh2.Activate

    If sh2.Cells(2, 1) = "" Then GoTo 1

    r = sh2.Cells(Rows.Count, 1).End(xlUp).Row

    ListBox1.RowSource = ""

    ListBox1.RowSource = sh2.Range("A2:F" & r).Address

    Old(col) = ComboBox1

    col = col + 1

    Label1.Caption = sh1.Cells(1, col)

    Set Rng = Range(sh2.Cells(2, col), sh2.Cells(r, col))

    On Error Resume Next

    For Each cl In Rng

        If Not IsError(cl) Then

            If cl <> "" Then cbx.Add cl.Value, CStr(cl.Value)

        End If

    Next cl

    On Error GoTo 0

    With ComboBox1

        .Clear

        For x = 1 To cbx.Count

            .AddItem cbx(x)

        Next x

        .ListIndex = 0

    End With

    sh1.Activate

    ComboBox1 = ""

    ComboBox1.SetFocus

1:

    Set Rng = Nothing

    Set cbx = Nothing

End Sub

'--------->>

Private Sub CommandButton1_Click()    'chiude userform

    UserForm1.Hide

End Sub

'--------->>

Private Sub CommandButton2_Click()    'torna selezione precedente

    col = col - 2

    If col = 0 Then UserForm_Activate: Exit Sub

    ComboBox1 = Old(col)

    ComboBox1_AfterUpdate

End Sub

'--------->>

Private Sub CommandButton3_Click()    'Modifica/inserisci dati inseriti

    Dim r, c, x, risp

    If R_r = "" Then risp = MsgBox("Attenzione! Nuovo inserimento?", vbInformation + vbYesNo, "Controllo dati")

    If risp = 7 Then Exit Sub

    r = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    If R_r = "" Then r = r + 1 Else r = R_r

    sh1.Cells(r, 1) = ComboBox2

    sh1.Cells(r, 2) = ComboBox3

    sh1.Cells(r, 3) = ComboBox4

    sh1.Cells(r, 4) = ComboBox5

    sh1.Cells(r, 5) = ComboBox6

    sh1.Cells(r, 6) = ComboBox7

    R_r = ""

    MsgBox "Operazione effettuata.", vbInformation, "Aggiornamento dati"

    UserForm_Activate

End Sub

'--------->>

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)    'seleziona riga da modificare

    Dim r, c, x, idx, Rng

    CommandButton2.Visible = False

    ListBox1.Height = 153

    idx = ListBox1.ListIndex

    For x = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row

        If sh1.Cells(x, 1) = ListBox1.List(idx, 0) And sh1.Cells(x, 2) = ListBox1.List(idx, 1) And _

           sh1.Cells(x, 3) = ListBox1.List(idx, 2) And sh1.Cells(x, 4) = ListBox1.List(idx, 3) And _

           sh1.Cells(x, 5) = ListBox1.List(idx, 4) And sh1.Cells(x, 6) = ListBox1.List(idx, 5) Then

            R_r = x

            ComboBox2 = ListBox1.List(idx, 0)

            ComboBox3 = ListBox1.List(idx, 1)

            ComboBox4 = ListBox1.List(idx, 2)

            ComboBox5 = ListBox1.List(idx, 3)

            ComboBox6 = ListBox1.List(idx, 4)

            ComboBox7 = ListBox1.List(idx, 5)

            Exit For

        End If

    Next x

End Sub

'--------->>

Private Sub UserForm_Activate()

    Dim r, x, cl, Rng, cbx As New Collection

    Dim arrColWidths() As String

    Dim sColWidths As String

    Dim i As Long

    SetFg

    sh1.Activate

    ReDim Old(1 To 5)

    r = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    With Me.ListBox1

        .Height = 420

        .ColumnHeads = True

        '   .RowSource = ""   '\ non serve!

        .RowSource = RngDati.Address(External:=True)     '\sh1.Range("A2:F" & rcols).Address

        .ColumnCount = LCol

        ReDim arrColWidths(1 To LCol)

For i = 1 To LCol

arrColWidths(i) = 50

Next i

sColWidths = Join(arrColWidths, ";")

.ColumnWidths = sColWidths

    End With

    On Error Resume Next

    For Each cl In RngDati.Cells

        With cl

            If Not IsError(cl) Then

                If .Value <> "" Then cbx.Add .Value, CStr(.Value)

            End If

        End With

    Next cl

    On Error GoTo 0

    With ComboBox1

        .Clear

        For x = 1 To cbx.Count

            .AddItem cbx(x)

        Next x

        .ListIndex = 0

    End With

    Indici

    col = 1

    CommandButton2.Visible = False

    Label1.Caption = sh1.Cells(1, col)

    ComboBox1 = ""

    ComboBox1.SetFocus

    Set Rng = Nothing

    Set cbx = Nothing

End Sub

'<<=========

Potresti scaricare ol file di prova Gio20170905.xlsm

Se vorresti sviluppare il tuo file di esempio per darlo un contenuto, sarò lieto a rivisitare questo codice.

Di nuovo, chiedo scusa per il ritardo con cui ti rispondo.

===

Regards,

Norman

Answer 2

Non ti preoccupare, succede.

Con gli aiuti che mi dai come non potrei scusarti......

Gio56

Answer 3

Ciao gio56,

sei mica riuscito a vedere i 2 file.

Ti devo chiedere scusa ! 

Avevo detto:

Link : Gestione mat completo.xlsm

https://www.dropbox.com/s/nzwkb7hi2pt5kv2/Gestione%20mat%20completo.xlsm?dl=0

Link : FiltraDati.xlsm

https://www.dropbox.com/s/m9cxf1jvdjc4ezh/FiltraDati.xlsm?dl=0

Ho scaricato entrambi questi file e li guarderò domani.

Da noi c'è un aforismo Tomorrow never comes (domani non arriva mai) e, purtroppo, pare che sia vero, almeno in questo caso, perchè in qualche modo il tuo thread è passato totalmente di mente  

Comunque, ti prometto che esaminarò i file e pubblicherò una soluzione stasera e, di nuovo, chiedo scusa.

===

Regards,

Norman

Answer 4

Ciao Norman,

sei mica riuscito a vedere i 2 file.

Grazie

Gio56

Answer 5

Ciao gio56,

[...]

Link : Gestione mat completo.xlsm

https://www.dropbox.com/s/nzwkb7hi2pt5kv2/Gestione%20mat%20completo.xlsm?dl=0

Link : FiltraDati.xlsm

https://www.dropbox.com/s/m9cxf1jvdjc4ezh/FiltraDati.xlsm?dl=0

Ho scaricato entrambi questi file e li guarderò domani.

===

Regards,

Norman