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

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

درود

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


http://exceliran.com/up/up/a10712189f58619ffbb3763328af96db.jpg (http://www.exceliran.com)


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



http://exceliran.com/up/up/8d0265e8621b3701d1c145d521965dd5.jpg (http://www.exceliran.com)



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




http://exceliran.com/up/up/257dbfb57ca4c053cedc7f59bbf8608c.jpg (http://www.exceliran.com)


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




http://exceliran.com/up/up/45ae2b2b73891faee20a0827abece33e.jpg (http://www.exceliran.com)


هر تکست باکس می بایست نام ستون متناظر خود در شیت اکسل را به اضافه حروف 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 نام لیست باکس را صحیح وارد کنید.

[hamedpersian]

سلام
ممنون. اما چرا از جدا.ل محوری (pivottable) استفاده نکنیم؟
با اونم خیلی راحت میشه همین کار رو انجام داد. نظرتون چیه؟

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

سلام
ممنون. اما چرا از جدا.ل محوری (pivottable) استفاده نکنیم؟
با اونم خیلی راحت میشه همین کار رو انجام داد. نظرتون چیه؟

راه که زیاده
پیشنهاد میکنم برای این موردی که مطرح کردید یک آموزش تهیه کنید که همه بهره ببریم:)

[4017]

با سلام
يه سوال
چطوري ليست باكس اين فرم از راست به چپ شده؟(البته معذرت ميخوام كه از اينهمه ماكروهاي قابل تحسين نظرم به اين مورد جلب شده)

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

البته اگر منظور شمارو درست متوجه شده باشم
تصویر پیوست رو مشاهده کنید

4120

[4017]

با تشكر از پاسخ شما
منظور من ستون هاي اين ليست باكسه كه از راست رديف/نام و ... داره
درحالي كه معمولا توي ليست باكس رديف يا هر ستون اولي كه ميخوايم نمايش بديم از چپ شروع ميشه

[4017]

با تشكر از پاسخ شما
منظور من ستون هاي اين ليست باكسه كه از راست رديف/نام و ... داره
درحالي كه معمولا توي ليست باكس رديف يا هر ستون اولي كه ميخوايم نمايش بديم از چپ شروع ميشه
دوستان اساتيد كسي نظري نداره؟

[khakzad]

سلام
جناب وطن پرست پاسخ شما رو دادن!!1
اون تنظیم رو انجام میدید
اما موقع تخصیص داده ها به لیست باکس به این دقت کنید که الولین مورد رو میاره از سمت چپ، پس باید اخرین مورد رو در ستون اول قرار بدید و همینطور به ترتیب
یعنی از اخر بیاید اول

[4017]

سلام
جناب وطن پرست پاسخ شما رو دادن!!1
اون تنظیم رو انجام میدید
اما موقع تخصیص داده ها به لیست باکس به این دقت کنید که الولین مورد رو میاره از سمت چپ، پس باید اخرین مورد رو در ستون اول قرار بدید و همینطور به ترتیب
یعنی از اخر بیاید اول
پاسخ شما متين
اما من توي همين فايلي كه اينجا پيوست شده ديدم كه ستونها از راست به چپ چيده شدن و ليست باكس هم همينو نشون داده. بازم ممنون

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

پاسخ شما متين
اما من توي همين فايلي كه اينجا پيوست شده ديدم كه ستونها از راست به چپ چيده شدن و ليست باكس هم همينو نشون داده. بازم ممنون

تو فایل پیوست جدول اطلاعات به عنوان سورس لیست باکس داده شده روش شما هم به همین صورته یا خیر؟

[4017]

تو فایل پیوست جدول اطلاعات به عنوان سورس لیست باکس داده شده روش شما هم به همین صورته یا خیر؟
راستش من تو بر اين فايل رفتم اما سر در نياوردم كه سورس اين جدول از كجا داده شده. من از طريق rowsurce آدرس دهي ميكنم

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

راستش من تو بر اين فايل رفتم اما سر در نياوردم كه سورس اين جدول از كجا داده شده. من از طريق rowsurce آدرس دهي ميكنم

فایلت رو بذار تا بررسی بشه چون همون جواب اولی که دادم راهکار سوال بود اما شاید ایراد از جای دیگه باشه

[4017]

فایلت رو بذار تا بررسی بشه چون همون جواب اولی که دادم راهکار سوال بود اما شاید ایراد از جای دیگه باشه
درسته با اون جواب ميشه انجامش داد. اما اين حس كنجكاوي من گل كرده و خواستم بدونم اينجا چه كاري كرده كه ليست باكسش از راست چيده شده

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

فایل و تصویر پیوست رو ببین

4153

[4017]

ممنون
جدول من به شكل tabel تغيير كرده اما تو فرم بازم همونه. ستونها از چپ چيده شده

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

تنها ترفند به کار رفته در فایل همین بوده که خدمت شما ارائه شد

[4017]

تنها ترفند به کار رفته در فایل همین بوده که خدمت شما ارائه شد

بله كاملا درسته. بايد ستونها رو جابجا كنم
ممنون از صبر و وقتي كه برام گذاشتين

[generalsamad]

سلام دوستان
اولین باره فرم میسازم
ایراد این فرم چیه؟
خطاش اینه

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

[khakzad]

سلام
میشه بفرمایید این فرم چکار میکنه و مشکل کجاست؟
این کدی که گذاشتید که خطا نیست.
بفرمایید در اجرای کدوم قسمت روی این کد خطا میده

[generalsamad]

این فرم عمل جستجو رو انجام میده
هر کدوم از فیلداش پر بشه باید تو جدول جستجو کنه و مشخصات فیلد پر شده رو در لیست باکس بیاره
طبق راهنمائی های ~M*E*H*D*I~ (http://forum.exceliran.com/member.php/2445-M*E*H*D*I) جلو رفتم اما چون بار اولم هست فرم میسازم جواب نداد.

[generalsamad]

مشکلی که داشتم حل شد
حواسم نبود اسم تکست باکس ها رو با سرستونها عوض کنم

[generalsamad]

با سلام
دوستان من میخوام برای جستجوی این فرم شرط بذارم
شرطی که میخوام بذارم اینه که مثلا اگه در فیلد نام تایپ کرد علی توی جدول هر نامی که علی توش باشه مثل محمد علی یا علی یار باشه رو تو لیست باکس بیاره
برای نام خانوادگی هم همینطور
دستور sql رو بلدم ولی نمیدونم چه جور باید تو این فرم استفادش کرد

where name,family like '*" & str & "*'
شاید هم اشتباه باشه
دوستان هر کس میتونه کمک کنه
ممنون

[ozviat83]

با سلام خسته نباشید
اگر امکان تمام قسمت های این کد را برام توضیح بدید ممنون میشم
تو اینترنت هر چی گشتم چیزی پیدا نکردم
راستش میخواهم با همین کدهایی که دادید که فیلتر درست کنم با این تفاوت که تعداد ستون ها و ردیف های بیشتری داره
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

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

با سلام خسته نباشید
اگر امکان تمام قسمت های این کد را برام توضیح بدید ممنون میشم
تو اینترنت هر چی گشتم چیزی پیدا نکردم
راستش میخواهم با همین کدهایی که دادید که فیلتر درست کنم با این تفاوت که تعداد ستون ها و ردیف های بیشتری داره
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



مباحثی که در این کدها مطرح شده مربوط به ADO هست که خودش یک مبحث مفصل و طولانیه ، برای فیلتر با تعدا بیشتر ستون نیازی به دستکاری کدها نیست کافیه به نکته زیر عمل کنید

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

[ozviat83]

این کار را کردم ولی به ارور میده که مربوط به خط
List(I - 1, J - 1) = rsReserve.Fields(J - 1).Value
هست

[ozviat83]

این کار را کردم ولی به ارور میده که مربوط به خط
List(I - 1, J - 1) = rsReserve.Fields(J - 1).Value
هست

[ozviat83]

کمـــــــــــــــــــــــ ــــــــــــــــک
این کار را کردم ولی به ارور میده که مربوط به خط
List(I - 1, J - 1) = rsReserve.Fields(J - 1).Value
هست

الان همون فایل را پیوست کردن تا ببینید
لطفا کمکم کنید

[ozviat83]

5700
تو این فایل که پیوست زدم ستون آخر را ضافه کردم که هنگامی که میخوام فیلتر را اعمال کنم ارور میده

[javad_khosravi]

سلام ببخشید میخواستم سلولهای تکراری از یک ستون رو در commbobox بدون حذف اون سلول ها انجام بدم و سلولهای خال انتخاب شده هم در کمبو باکس نمایش داده نشه همانند تکراری ها.ممنون میشم راهنماییم کنین.

[iranweld]

با سلام

راه اول با استفاده از Advance fillter یک لیست بدون تکرار از لیست خود ایجاد کنید و سپس آنها را به کمبوباکس ارتباط دهید



Private Sub UserForm_Initialize()

Z1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A1:A" & Z1).AdvancedFilter Action:=xlFilterInPlace, Unique:=False
Range("A1:A" & Z1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"B1"), Unique:=True

Z2 = Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row

For I = 2 To Z2

ComboBox1.AddItem Range("B" & I)

Next

End Sub

راه دوم با استفاده از Collection یک لیست بدون تکرار و خالی در حافظه ایجاد کنید و سپس به کمبوباکس ارتباط دهید

[javad_khosravi]

با سلام

راه اول با استفاده از Advance fillter یک لیست بدون تکرار از لیست خود ایجاد کنید و سپس آنها را به کمبوباکس ارتباط دهید



Private Sub UserForm_Initialize()

Z1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A1:A" & Z1).AdvancedFilter Action:=xlFilterInPlace, Unique:=False
Range("A1:A" & Z1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"B1"), Unique:=True

Z2 = Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row

For I = 2 To Z2

ComboBox1.AddItem Range("B" & I)

Next

End Sub

راه دوم با استفاده از Collection یک لیست بدون تکرار و خالی در حافظه ایجاد کنید و سپس به کمبوباکس ارتباط دهید

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

[javad_khosravi]

اینم فایل

[iranweld]

کمبوباکس های شما با کدوم آیتمها باید پر بشه؟
حداقل روی سرستونها نام آیتم مورد نظر رو بنویسید که مشخص بشه کمبوباکس ها از کجا باید دیتاشون بگیرند

[javad_khosravi]

[QUOTE=iranweld;52153]کمبوباکس های شما با کدوم آیتمها باید پر بشه؟
حداقل روی سرستونها نام آیتم مورد نظر رو بنویسید که مشخص بشه کمبوباکس ها از کجا باید دیتاشون بگیرن


مرسی و ممنون . اسم هر کمبو باکس مربوط به ستونش رو تو این فایل نوشتم.

[iranweld]

فایل پیوست را بررسی بفرمایید

مقدار دهی شما در کمبوباکس های مورد نظر یکساعتی ما رو سرکار گذاشت

[javad_khosravi]

فایل پیوست را بررسی بفرمایید

مقدار دهی شما در کمبوباکس های مورد نظر یکساعتی ما رو سرکار گذاشت

مرسی ممنون خیلی لطف کردین.

[yasan100]

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

[alireza1350]

سلام به تمامی اساتید محترم

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

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

به مشکل خوردم و ان هم ناتوانی و کم سوادی بنده در vba بود

حالا اگه زحمتی نیست کمک کنید تا این نرم افزار برای بنده بهینه بشه

سوال در شیت sett همانگونه که می بینید یک سری کد ها و تعاریف جلوی ان قرار گرفته مثلا من می خوام در کد 111 مسافرت و تور بجای 4 کد تعریف

شده 10 کد تعریف کنم یعنی کد اولیه 110 الی 119 و گردش و تفریح و حذف کنم و موارد شخصی از 120 الی 129 تعریف کنم ولی نتونستم لطفا راهنمایی کنید فایل اصلی را هم اینجا می گذارم .

سپاس از همه

[mj1489]

سلام علیکم
من مطابق آموزش های مدیر ارشد ~M*E*H*D*I (http://forum.exceliran.com/member.php/2445-M*E*H*D*I) مرحله به مرحله پیش رفتم ولی وقتی فرم را فراخوانی می کنم و در قسمت نام یا نام خانوادگی اسمی را وارد می کنم ارور میده
لطفا بنده رو راهنمایی نمایید و بفرمایید اشکال کار بنده کجاست
ممنونم
فایل رو هم ضمیمه می کنم

[foad_m]

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

[foad_m]

سلام من تو قسمت کد زیر مشکل دارم
.List(I - 1, J - 1) = rsReserve.Fields(J - 1).Value
ستون های من تا S ادامه داره کسی میتونه راهنمایی کنه ؟

[kamranmozafari2]

بسیار عالی

[estineva]

باسلام خدمت دوستان وقتتون بخیر
من مثل فایل شما درست کردم نمیدونم چرا هرکاری میکنم ارور میده ممنون میشم راهنمایی کنید خیلی این فایل بکارم میاد

ممنون از لطف شما سروران گرامی