رشاد احمد قام بنشر فبراير 16 مشاركة قام بنشر فبراير 16 السلام عليكم ورحمة الله وبركاته تحيه للقائمين على المنتدى والخبراء والاعضاء ارجو التكرم ان امكن بالمساعده بكود بحث حسب القائمه المنسدله فى شيت البحث المرفق بحيث يظهر كل السيارات حسب حالتها واشكركم جميعا وكل عام وانتم بخير ,,, السيارات 24.xlsx رابط هذا التعليق شارك More sharing options...
أبومروان قام بنشر فبراير 16 مشاركة قام بنشر فبراير 16 وعليكم السلام ورحمه وبركاته جرب المرفق لعله الملطلوب تم الاستعانه بالموضوع ادناه السيارات 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 1 رابط هذا التعليق شارك More sharing options...
رشاد احمد قام بنشر فبراير 17 الكاتب مشاركة قام بنشر فبراير 17 شكرا جزيلا لك اخى ابو مروان , لكن لا اعلم كيفية تطبيق ذلك على الملف 1 رابط هذا التعليق شارك More sharing options...
أبومروان قام بنشر فبراير 17 مشاركة قام بنشر فبراير 17 أ/ @رشاد احمد ارفقت لحضرتك في المشاركه السابقه الملف جاهز عندالتغير سوف يتم استدعاء المطلوب وحول تقرا الموضع هيفيدك ويساعدك للوصول لافضل حل وفهم الكود رابط هذا التعليق شارك More sharing options...
رشاد احمد قام بنشر فبراير 17 الكاتب مشاركة قام بنشر فبراير 17 عموما ساحاول لك كل الشكر والتقدير 1 رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر فبراير 17 أفضل إجابة مشاركة قام بنشر فبراير 17 في حدث 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 3 رابط هذا التعليق شارك More sharing options...
رشاد احمد قام بنشر فبراير 17 الكاتب مشاركة قام بنشر فبراير 17 (معدل) كل الشكر لك اخى محمد هشام وبارك الله فيك . تمام هذا هو المطلوب لكن عند تغيير البحث من القائمه تكون النتيجه غير محدده ومتداخله فى بعض الاختيارات فقط فى اختيار " التامين ساريه " و الفحص ساريه وباقى الاختيارات تمام التمام تم تعديل فبراير 17 بواسطه رشاد احمد رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر فبراير 17 مشاركة قام بنشر فبراير 17 اظن ان دالك بسبب طريقة تصميمك للملف حاول فلترة بياناتك يدويا ستجد نفس التداخل في العناصر المدكورة رابط هذا التعليق شارك More sharing options...
رشاد احمد قام بنشر فبراير 17 الكاتب مشاركة قام بنشر فبراير 17 تمام تم حل المشكله اكرر شكرى لحضرتك وكل الاداريين والخبراء والاعضاء رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.