مساعدة في البحث في اكسيل

[الو11111في]

السلام عليكم 

ارجو المساعدة  ربي يسعدكم 

لدي ملف اكسيل بياناته تقريبا 10الاف صف 

من ضمن البيانات يوجد عمود اسمه رمز القطعة 

وأريد ان اقوم بتجميع بيانات كل مجموعة رموز  على حدة  

هل يوجد دالة للبحث   اضع فيها اكثر من رمز مثلا K1 , K2 , K3  , K4     وتقوم باسترجاع صف البيانات كامل  من مجموعة السجلات الضخمه 

لأني حاليا جالس ابحث برمز واحد فقط ثم اقوم بنسخ الصف  وهكذا   وهي متعبه جدا 

هذه نسخه تجريبية من البيانات 

المطلوب

اريد دالة تقوم بتحديد اكثر من صف  بناء على البحث بواسطة اكثر من رقم وزاري 

مثلا 

اكتب S-647764 و  S-67489  و  S-6789765

فتظهر لي الصفوف المطلوبة  من اصل 10 الاف سجل

شكرا

 

تقرير.xlsx

[سليم حاصبيا]

ارفع نموذجاً (حوالي 20 صف من البيانات ) لمعالجة الامر

[حسين مامون]

بعد اذن استاذي سليم

جرب المرفق 

تمنى ان يكون ما تتمناه

تقرير.xlsm

[الو11111في]

اشكرك اخوي حسين 

لكن الطريقة اللي عملتها انت  لابد اختار الرمز من بين تقريبا 2000 رمز   وهذي متعبه لأن البيانات ضخمة 

انا مثلا اريد ادخال (كتابة)  4 او 5 رموز  دفعة واحدة  ويسترجع لي بياناتها 

مثلا حقل او عدة حقول  اكتب فيها الرموز  وتظهر لي بياناتها  

اكرر الشكر لك اخوي حسين 

[حسين مامون]

جرب الطريقة دي

تقرير.xlsm

[سليم حاصبيا]

بعد اذن الاستاذ حسين

تجد البيانات في شيت salim

ربما يفيدك هذا الكود(دائما وابدً اسماء الشيتات باللغة الاجنبية لحسن نسخ الكود ولصقه)

Option Explicit

Sub extract_data()
Dim M As Worksheet, S As Worksheet
Dim Rg_M As Range, Rg_S As Range
Dim i#, Ro_M#, RoS#, col%, f#: f = 4
Dim My_data, Find_rg

Set M = Sheets("Main"): Set S = Sheets("Salim")
Set Rg_S = S.Range("A3").CurrentRegion
RoS = Rg_S.Rows.Count
If RoS > 1 Then Rg_S.Offset(1).Resize(RoS - 1).Clear
col = S.Cells(1, Columns.Count).End(1).Column
My_data = _
Application.Transpose(Application.Transpose(S.Cells(1, 1).Resize(, col)))
  Set Rg_M = M.Range("A1").CurrentRegion
  Ro_M = Rg_M.Rows.Count
  Set Rg_M = Rg_M.Offset(1).Resize(Ro_M - 1)
 For i = 1 To Rg_M.Rows.Count
 
    If Not IsError(Application.Match(Rg_M.Cells(i, 1), My_data, 0)) Then
      S.Cells(f, 1).Resize(, 9).Value = _
      Rg_M.Cells(i, 1).Resize(, 9).Value
      f = f + 1
    End If
  
 Next
 If f > 4 Then
 With S.Range("A4").Resize(f - 4, 9)
 .WrapText = True
 .Borders.LineStyle = 1
 .VerticalAlignment = 2
 .InsertIndent 1
 End With
  
 End If
End Sub

 

الملف مرفق مع زر لتنفيذ الكود

Repoort_sal.xlsm

[الو11111في]

بالضبط هذا اللي ابيه اخوي حسين 

لكن كيف الطريقة ؟  لأن بطبقة على ملف آخر 

اريد تغيير النطاق للبحث  مع الملف الآخر 

 

جزاك الله كل خير 

اولا الله يجزاك كل خير اخوي سليم 

لكن انا اجهل استخدام الاكواد نهائيا  

كيف الطريقة للتعديل ليتوافق مع ملف الاكسيل الذي به البيانات

اكرر الشكر لكم 

فعلا منتدى مفيد جداً 

 

[حسين مامون]

اليس الملف الذي قمت بتحميله نمودج عن الملف المعني

[الو11111في]

نعم لكن ينقصه بعض الاعمده  واريد استرجاع بياناتها 

اضفتها لك هنا   بالملف المرفق  وتتضح باللون الاصفر

وانا سأقوم بنسخ البيانات في شيت "ورقة 1 "

اعتذر منك اخوي

 

تم تعديل فبراير 10, 2020 بواسطه الو11111في
خطأ

[سليم حاصبيا]

للببيانات الكبيرة جداً (اكثر من 1000 صف )الماكرو يستهلك الكثير من الوقت

لذلك انصح لمثل هذه الحالة هذا الماكرو

Option Explicit

Sub extract_BY_ADV_FILTER()
Dim M As Worksheet, S As Worksheet
Dim Rg_M As Range, Rg_S As Range
Dim i#, RoS#, col%
Dim My_data

Set M = Sheets("Main"): Set S = Sheets("Salim1")
Set Rg_S = S.Range("A4").CurrentRegion
Set Rg_M = M.Range("A1").CurrentRegion

RoS = Rg_S.Rows.Count
If RoS > 1 Then Rg_S.Offset(1).Resize(RoS - 1).Clear
col = S.Cells(1, Columns.Count).End(1).Column
My_data = _
    Application.Transpose(Application.Transpose(S.Cells(1, 1) _
    .Resize(, col)))

S.Range("MM2") = Sheets("Main").Cells(1, 1)
S.Range("MM3").Resize(col) = Application.Transpose(My_data)

   Rg_M.AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=S.Range("MM2").CurrentRegion, _
    CopyToRange:=S.Range("A4").Resize(, 9)
    S.Range("MM2").CurrentRegion.Clear
End Sub

الصفحة  Salim1 من  هذا الملف

Repoort_sal_by_ad filter.xlsm

[الو11111في]

أسعدك الله  أخي الغالي  سليم 

لكن مثل ماذكرت انا أجهل هذه الاكواد  وما استطيع اعدل عليها 

اتمنى يتم التعديل على ملف اخونا حسين  لأنه الأقرب لعملي  

فقط يحتاج اظهار اعمده اضافية في عند البحث  وحددتها باللون الأصفر 

أكرر الشكر لكم والله يجعل ماتقومون به من خدمه للناس في موازين اعمالكم يوم لاينفع مالا ولابنون

[الو11111في]

هذا الملف الذي اريد التعديل عليه 

تقرير 8.rar

[حسين مامون]

اليك المرفق 

 

تقرير 8.xlsm

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim SH As Worksheet
Set SH = Sheets("ورقة1")
Dim rr, lr, x, m
Range("b5:i10000").ClearContents
rr = Cells(Rows.Count, 1).End(xlUp).Row
lr = SH.Cells(Rows.Count, 1).End(xlUp).Row
For m = 5 To rr
If Cells(m, 1).Text = "" Then Exit Sub
For x = 2 To lr
If Cells(m, 1).Text = SH.Cells(x, 1).Text Then
Cells(m, 1).Select
With Sheets("sheet1")
.Cells(m, 2).Resize(1, 115).Value = SH.Cells(x, 2).Resize(1, 115).Value

End With

End If
Next

Next
Application.ScreenUpdating = True

End Sub

 

[الو11111في]

يوجد صف بيانات يظهر بشكل خاطئ  

اعمل بحث عن الرمز الأول S-4183218

ومن ثم اعمل حذف للرمز واضغط استعلام 

لايتم مسح البيانات بشكل كامل

البيانات من العمود  J

[حسين مامون]

تقرير 8.xlsm

[الو11111في]

الله يوفقك ويسعدك  اخوي حسين