Ricerca parziale del testo e risultati in listbox

Question

Buongiorno a tutti,

come state?..

Ho un piccolo problema da risolvere con il vba Excel e chiedo gentilmente il vostro aiuto.

In un file Excel ho 2 fogli (sheet1 e sheet2), in sheet1 ho una lista di nomi che è spartita in questo modo:

colonna A = nomi

colonna B = specialità

colonna C = email

colonna D, E, F = prezzi

in sheet2 ho l'userform che serve appunto a ricercare il testo.

L'userform è così composta: textbox1 per la ricerca parziale (specialità, sheet1), listbox1 per i risultati che otterrò dalla ricerca parziale, un commandbutton1 che fa il "lavoro" del cercare.

Il mio intento è quello di fare la ricerca, anche parziale, delle specialità (colonna B) tramite la textbox1 e una volta che clicco sul tasto "cerca"(commandbutton1), nella listbox escano i risultati, ma devono uscire tutte le colonne A:F.

Esempio: a intervalli irregolari ci sta per 3 volte la specialità "idraulico", nella textbox1 scrivo idraulico, click sul pulsante e nella listbox escono tutti i risultati A:F per quanto riguarda idraulico.

Questo è il codice che è associato al commandbutton1 (riporta SOLO la colonna B):

Option Compare Text

Private Sub CommandButton1_Click()

Dim rng As Range

Dim c As Range

Dim a As String

With Worksheets("Sheet1")

Set rng = .Range(.Cells(1, 2), .Cells(.Cells(65536, 2).End(xlUp).Row, 1))

a = "*" & TextBox1 & "*"

    For Each c In rng

If c.Value Like a Then

            ListBox1.AddItem (c.Value)

        End If

    Next

End With

   Set rng = Nothing

End Sub

Se avreste bisogno di delucidazioni, chiedete pure.

Grazie mille in anticipo a chi vorrà aiutarmi e buona continuazione. :)

Sol39

Answer 1

Ciao Sol39,

Dato il requisito di filtrare il contenuto del controllo ListBox, non è direttamente possibile aggiungere le intestazioni di colonna. 

Esistono due modi per ovviare a questo problema: sia aggiungere 6 etichette sopra la Listbox (vedi il file di prova che ho caricato) che, in alternativa, creare una seconda ListBox per visualizzare solo la riga di intestazione.

Se preferiresti questa seconda soluzione, modificherò di conseguenza il mio file di prova.

Per adottare questa seconda soluzione, prova a sostituire il codice con la seguente versione:

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

Option Explicit

Option Compare Text

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

Public Sub Crea_Intestazioni(lbx_Body As MSForms.ListBox, _

                               lbx_Header As MSForms.ListBox, _

                               arrHeaders As Variant)

Dim i As Long

  With lbx_Header

    .ColumnCount = lbx_Body.ColumnCount

    .ColumnWidths = lbx_Body.ColumnWidths

    .Clear

    .AddItem

    For i = 0 To UBound(arrHeaders)

        .List(0, i) = arrHeaders(i)

    Next i

    lbx_Body.ZOrder (1)

    .ZOrder (0)

    .SpecialEffect = fmSpecialEffectFlat

    .BackColor = RGB(200, 200, 200)

    .Height = 10

    .Width = lbx_Body.Width + 12

    .Left = lbx_Body.Left

    .Top = lbx_Body.Top - (.Height - 1)

    End With

End Sub

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

Private Sub UserForm_Activate()

    Call Crea_Intestazioni(Me.ListBox1, _

              Me.ListBox2, Array("Nome", "Specialità", _

              "Email", "Costo1", "Costo2", "Costo3"))

End Sub

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

Private Sub UserForm_Initialize()

    With Me.ListBox1

        .ColumnCount = 6

        .ColumnWidths = "70;70;125,90;90;70"

    End With

End Sub

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

Private Sub CommandButton1_Click()

    Dim Rng As Range, rCell As Range

    Dim arrIn As Variant, arrOut() As Variant

    Dim sStr As String

    Dim i As Long, j As Long, iCtr As Long

    Dim UB As Long, UB2 As Long

    With Worksheets("Sheet1")

        Set Rng = .Range(.Cells(1, 1), _

                         .Cells(.Cells(65536, 2).End(xlUp).Row, 1))

        Set Rng = Rng.Resize(, 6)

        arrIn = Rng.Value

        UB = UBound(arrIn)

        UB2 = UBound(arrIn, 2)

        sStr = "*" & TextBox1.Text & "*"

        For i = 1 To UB

            If arrIn(i, 2) Like sStr Then

                iCtr = iCtr + 1

                ReDim Preserve arrOut(1 To UB2, 1 To iCtr)

                For j = 1 To UB2

                    arrOut(j, iCtr) = arrIn(i, j)

                Next j

            End If

        Next i

    End With

    If CBool(iCtr) Then

        Me.ListBox1.Column = arrOut

    Else

        Me.ListBox1.Clear

        Call MsgBox( _

             Prompt:="Nessun record trovato!", _

             Buttons:=vbInformation, _

             Title:="REPORT")

    End If

End Sub

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

Potresti scaricare il mio file di prova Sol2_20200403.xlsm

===

Regards,

Norman

Answer 2

Ciao Norman,

inutile dire che il codice va benissimo!

Solo una cosa per renderlo perfetto...come si fa ad inserire le intestazioni della colonna in listbox?

In modo che esca nome, specialità, email ecc..

Grazie mille dell'aiuto!

Answer 3

Ciao Sol39,

Gentilissimo Norman,

grazie mille per aver risposto!

Qui puoi trovare il link al file:  https://we.tl/t-4TdvRfAAuA

Grazie mille ancora

Nel modulo di codice della Userform, prova qualcosa del genere:

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

Option Explicit

Option Compare Text

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

Private Sub UserForm_Initialize()

    With Me.ListBox1

        .ColumnCount = 6

        .ColumnWidths = "70;70;125,90;90;70"

    End With

End Sub

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

Private Sub CommandButton1_Click()

    Dim Rng As Range, rCell As Range

    Dim arrIn As Variant, arrOut() As Variant

    Dim sStr As String

    Dim i As Long, j As Long, iCtr As Long

    Dim UB As Long, UB2 As Long

    With Worksheets("Sheet1")

        Set Rng = .Range(.Cells(1, 1), .Cells(.Cells(65536, 2).End(xlUp).Row, 1))

        Set Rng = Rng.Resize(, 6)

        arrIn = Rng.Value

        UB = UBound(arrIn)

        UB2 = UBound(arrIn, 2)

        sStr = "*" & TextBox1.Text & "*"

        For i = 1 To UB

            If arrIn(i, 2) Like sStr Then

                iCtr = iCtr + 1

                ReDim Preserve arrOut(1 To UB2, 1 To iCtr)

                For j = 1 To UB2

                    arrOut(j, iCtr) = arrIn(i, j)

                Next j

            End If

        Next i

    End With

    Me.ListBox1.Column = arrOut

End Sub

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

Potresti scaricare il mio file di prova Sol20200402.xlsm

===

Regards,

Norman

Answer 4

Gentilissimo Norman,

grazie mille per aver risposto!

Qui puoi trovare il link al file:  https://we.tl/t-4TdvRfAAuA

Grazie mille ancora

Answer 5

Ciao Sol39,

Ho un piccolo problema da risolvere con il vba Excel e chiedo gentilmente il vostro aiuto.

In un file Excel ho 2 fogli (sheet1 e sheet2), in sheet1 ho una lista di nomi che è spartita in questo modo:

colonna A = nomi

colonna B = specialità

colonna C = email

colonna D, E, F = prezzi

in sheet2 ho l'userform che serve appunto a ricercare il testo.

L'userform è così composta: textbox1 per la ricerca parziale (specialità, sheet1), listbox1 per i risultati che otterrò dalla ricerca parziale, un commandbutton1 che fa il "lavoro" del cercare.

Il mio intento è quello di fare la ricerca, anche parziale, delle specialità (colonna B) tramite la textbox1 e una volta che clicco sul tasto "cerca"(commandbutton1), nella listbox escano i risultati, ma devono uscire tutte le colonne A:F.

Esempio: a intervalli irregolari ci sta per 3 volte la specialità "idraulico", nella textbox1 scrivo idraulico, click sul pulsante e nella listbox escono tutti i risultati A:F per quanto riguarda idraulico.

Questo è il codice che è associato al commandbutton1 (riporta SOLO la colonna B):

Option Compare Text

Private Sub CommandButton1_Click()

Dim rng As Range

Dim c As Range

Dim a As String

With Worksheets("Sheet1")

Set rng = .Range(.Cells(1, 2), .Cells(.Cells(65536, 2).End(xlUp).Row, 1))

a = "*" & TextBox1 & "*"

    For Each c In rng

If c.Value Like a Then

            ListBox1.AddItem (c.Value)

        End If

    Next

End With

   Set rng = Nothing

End Sub

Se avreste bisogno di delucidazioni, chiedete pure.

Per evitare che sia necessario ricreare il tuo file, ti chiedo gentilmente di caricare un file di esempio, privo di dati sensibili.

Per caricare il file su Microsoft OneDrive, vedi:

   Condividere file e cartelle di OneDrive

===

Regards,

Norman