كودبحث حسب القائمه المنسدله

[رشاد احمد]

السلام عليكم ورحمة الله وبركاته

تحيه للقائمين على المنتدى والخبراء والاعضاء

ارجو التكرم ان امكن بالمساعده بكود بحث حسب القائمه المنسدله فى شيت البحث المرفق

بحيث يظهر كل السيارات حسب حالتها واشكركم جميعا وكل عام وانتم بخير ,,,

السيارات 24.xlsx

[أبومروان]

وعليكم السلام ورحمه وبركاته

جرب المرفق لعله الملطلوب

تم الاستعانه بالموضوع ادناه

السيارات 24.xlsm

ودا الكود المستخدم عدل عليه براحتك حسي الاحتياج

Sub Trans_Data()

'????? ??? ???????? ???? ??????
'????? ????
'?? ??? ????? ?? 15/11/2017
'????? ?? ????? ?? ??????? ???? ????? ????
'================
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'??????? ?? ????? ???????'
Dim Main As Worksheet, sh As Worksheet

'  ??????? ?? ??????????
Dim Arr As Variant, Temp As Variant

'(i,j)??????? ?? ????? ???????? ?????? ( p  ) ????? ???????? ???????
Dim i As Long, j As Long, p As Long

' ??????? ?? ??????? ???? ??? ??? ????? ????
Dim dep As String

Set Main = Sheets("1")
Set sh = Sheets("2")
'=======
'  ??? ??????? ???????
sh.Range("A5:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

'    ????? ????????
dep = sh.Range("e2").Value

 '     ???????? ??????
Arr = Main.Range("A3:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value

'     ????? ???????? ?????
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

 '     ??? ???????? ??????
For i = 1 To UBound(Arr, 1)

 '??? ???? ?????
If Arr(i, 4) Like "*" & dep & "*" Then

'If Arr(i, 101) = dep Then
 '    ?????? ?????? ??? ???????? ?????
p = p + 1

 '     ??? ???????? ?????
For j = 1 To UBound(Arr, 2)

'  ????? ???????? ????? ?? ???????? ?????? ??? ?????
Temp(p, j) = Arr(i, j)

Next
End If
Next

 '  ???? ??????? ????? ?????
 '??? ???????? ????????
If p > 0 Then sh.Range("A5").Resize(p, UBound(Temp, 2)).Value = Temp

       sh.Range("A5:AC" & Rows.Count).Borders.Value = 0
        
        '??? ?????? ???????
       sh.Range("A5:AC" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _
       .Weight = xlMedium
        
     ' .Weight = xlThin
     ' .Weight = xlMedium
     ' .Weight = xlThick

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

 

[رشاد احمد]

شكرا جزيلا لك اخى ابو مروان , لكن لا اعلم كيفية تطبيق ذلك على الملف

[أبومروان]

أ/ @رشاد احمد ارفقت لحضرتك في المشاركه السابقه الملف جاهز عندالتغير سوف يتم استدعاء المطلوب وحول تقرا الموضع  هيفيدك ويساعدك للوصول لافضل حل وفهم الكود

 

[رشاد احمد]

عموما ساحاول لك كل الشكر والتقدير

[محمد هشام.]

في حدث Private Sub Worksheet_Activate ضع الكود التالي 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, i&, k&, b$, S$, lRow&
Dim WS As Worksheet: Set WS = Sheets("البيانات")
Dim desWS As Worksheet: Set desWS = Sheets("البحث")
b = desWS.[E2]

On Error Resume Next
Application.ScreenUpdating = False
If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then
If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub
desWS.Range("A5:j" & Rows.Count).ClearContents
a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row)
For i = 1 To UBound(a)
    If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then
  desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "")
       k = k + 1
     ActiveWindow.DisplayZeros = False
        End If
    Next
lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Rng = desWS.Range("A5 :J" & lRow)
    desWS.Range("A5:J500").Borders.LineStyle = xlNone
   For Each c In Rng.Rows
If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
        Next
   Application.ScreenUpdating = True
  End If
End Sub

 

السيارات 24.xlsb

[رشاد احمد]

كل الشكر لك اخى محمد هشام وبارك الله فيك .

تمام هذا هو المطلوب لكن عند تغيير البحث من القائمه تكون النتيجه غير محدده ومتداخله فى

بعض الاختيارات فقط فى اختيار " التامين ساريه " و الفحص ساريه وباقى الاختيارات تمام التمام

تم تعديل فبراير 17, 2024 بواسطه رشاد احمد

[محمد هشام.]

اظن ان دالك بسبب طريقة تصميمك للملف  حاول فلترة بياناتك يدويا ستجد نفس التداخل في العناصر المدكورة  

[رشاد احمد]

تمام تم حل المشكله اكرر شكرى لحضرتك وكل الاداريين والخبراء والاعضاء