آموزش فیلتر داده ها بر مبنای چند محدودیت اختیاری و نمایش در لیست باکس

[~M*E*H*D*I~]

درود

در این تاپیک هدف ارائه راهکاری برای جستجوی چندگانه است و قصد توضیح دادن کد هارو ندارم ، برای اجرا شدن کد ها ابتدا از مسیر VBA/Tools/Refrences گزینه Microsoft Activex Data objects رو فعال کنید

فرض کنید جدولی با داده هایی به شکل زیر دارید

هدف فیلتر کردن داده ها به صورت گام به گام و همراه با چندین شرط متفاوت و در نهایت رسیدن به رکورد مورد نیاز و نمایش آن در لیست باکس یک فرم است
گام اول:
ابتدا فرم مورد نیاز خود را طراحی کنید و آیتم های مورد نیاز خود را در قالب یک تکست باکس یا کمبو باکس ایجاد نمایید

از مسیری که در تصویر زیر مشخص شده است نسبت به نام گذاری تکست باکس ها (یا کمبو باکس ها) به روش زیر اقدام نمایید

هر تکست باکس می بایست نام ستون متناظر خود در شیت اکسل را به اضافه حروف flt در پایان آن داشته باشد به عنوان مثال ستون نام در شیت به fname نامگذاری شده است پس تکست باکس آن را با fnameflt نام گذاری کنید.

گام سوم:
کانکشن مورد نیاز به شیت حاوی داده ها ایجاد کنید ، با توجه به اینکه این کانکشن در طول اجرای سابروتین ها مورد نیاز است متغیر های مربوطه را به صورت public تعریف میکنیم:

Public cnn As ADODB.Connection
Public rsReserve As ADODB.Recordset
Public Sub constr()
Dim strSQL As String
Dim fpath As String
Dim str As String
Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set rsReserve = New ADODB.Recordset
fpath = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name
str = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" _
                        & fpath & """;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
strSQL = "select*from [sheet1$]"
cnn.Open str
rsReserve.Open strSQL, cnn, adOpenForwardOnly, adLockReadOnly, adCmdText
End Sub 

کد زیر شیت حاوی اطلاعات را انتخاب میکند

strSQL = "select*from [sheet1$]" 

گام سوم:
با استفاده از رویداد click کامند باتن تعبیه شده بر روی یوزر فرم کدهای زیر را وارد کنید:

Private Sub CommandButton1_Click()
Dim cCont As Control
Dim fildname As String
Dim filtername As String
Dim srtfill As String
Call constr
    For Each cCont In Me.Controls
If UCase(Right(cCont.Name, 3)) = "FLT" Then
fildname = Mid(cCont.Name, 1, Len(cCont.Name) - 3)
filtername = cCont.Value
If filtername <> "" Then
srtfill = srtfill & flt(fildname, filtername)

End If
End If

    Next cCont
   srtfill = Mid(srtfill, 1, Len(srtfill) - 5)
    Call subfilter(srtfill)
       Call filllistbox

Set rsReserve = Nothing
Set rs = Nothing
cnn.Close
End Sub 

این رویه در ابتدا اقدام به برقراری کانکشن نموده و با تشخیص مقادیری که شما وارد کرده اید سابروتین زیر را که اقدام به ساخت استرینگ مورد نیاز برای فیلتر کردن داده می نماید فراخوانی می کند.

Public Function flt(fildname As String, filtername As String)
flt = " " & fildname & "  =    '" & filtername & "' AND "
End Function 

گام چهارم:

بعد از ساخت استرینگ مورد نیاز قطعه کد زیر فراخوانی شده و داده ها فیلتر می شوند.

Sub subfilter(srtfill As String)
rsReserve.Filter = srtfill
End Sub 

گام پنجم:

در پایان با فراخوانی سابروتین زیر داده ها در لیست باکس وارد می شود

Private Sub filllistbox()

    Dim I As Integer, J As Integer

    With ListBox1
   
        .BoundColumn = 1
        .ColumnCount = rsReserve.Fields.Count
        .ColumnHeads = False
        .ColumnWidths = ""
        .ControlSource = ""
        .RowSource = ""
        .Clear
        I = 0
     
        If Not rsReserve.BOF Then rsReserve.MoveFirst
        If rsReserve.EOF = True Then
        MsgBox "this record nor exist"
        End If
        Do Until rsReserve.EOF
            I = I + 1
            .AddItem
            For J = 1 To .ColumnCount
                .List(I - 1, J - 1) = rsReserve.Fields(J - 1).Value
            Next J
           rsReserve.MoveNext
        Loop
    End With


End Sub 

دقت کنید در گزاره with نام لیست باکس را صحیح وارد کنید.

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.