بحث بأكثر من شرط في عدة شيتات مع ذكر رقم الشيت

[هادي أحمد]

العملاء.xlsm

مشاركة مكررة ... تـــم بالفعل حذف المشاركة الأخرى

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

جرب هذا الكود

Sub Filter_me()
Dim Ar_sh(), Itm
Dim M As Worksheet
Dim Ro%, t%, i%, k%, Y%
Dim Cret As Range
Dim Filter_rg As Range
Set M = Sheets("Main")
Set Cret = M.Range("A2:L3")

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

k = -1
For i = 1 To Sheets.Count
If Sheets(i).Name <> M.Name Then
  k = k + 1
  ReDim Preserve Ar_sh(k)
  Ar_sh(k) = Sheets(i).Name
End If
Next
t = 8: Y = 8
M.Range("A8:N5000").ClearContents
For Each Itm In Ar_sh
    With Sheets(Itm)
        If .FilterMode Then .ShowAllData
        Ro = .Cells(Rows.Count, 1).End(3).Row
        Set Filter_rg = .Cells(3, 1).Resize(Ro - 3, 12)
        
        Filter_rg.AdvancedFilter 1, Cret
        .Range("A4").Resize(Ro - 3, 12).SpecialCells(12).Copy
         M.Cells(t, 1).PasteSpecial (12)
        t = M.Cells(Rows.Count, 1).End(3).Row + 1
        M.Cells(Y, "N").Resize(t - Y) = .Name
        Y = t
        If .FilterMode Then .ShowAllData
    End With
Next Itm

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With

End Sub

الملف مرفق

Hadi.xlsm

[هادي أحمد]

في البداية احب ان اشكرك علي عظيم مجهودك

 وبعد اذنك أستاذ سليم أنا لما قمت بعمل البحث ظهر بعض الأخطاء كما هو واضح بالصورة المرفقة

[محي الدين ابو البشر]

السلام عليكم

انطلاقاً من الكود الموجود إليك:

Sub Test()
    Dim lr1, lr2
    Dim i
    Application.ScreenUpdating = False
    Cells(5, 1).CurrentRegion.Offset(1).ClearContents
    For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count - 1, Range("m3")) - 1
        With Sheets(CStr(i))
            lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets(CStr(i)).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _
                                                             CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1)
            Cells(lr1, 1).Resize(, 12).Delete
            lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = i
        End With
    Next
    Range("I10").Select
    Application.ScreenUpdating = True
End Sub

 

[هادي أحمد]

مشكور استاذ محي 

لو أمكن شرح للكود

والبحث بيبحث في الشيتات ماعدا أخر شيت

ولو عايز اضيف شيت او احذف شيت بس من الأول لاني حاولت احذف الشيت رقم 1 طلع رسالة خطأ

ولو الشيت مفيهوش بيانات من المستعلم عنها بيسيب صف فاضي في البحث

[محي الدين ابو البشر]

what about

Sub Test()
    Dim lr1, lr2
    Dim i
    Application.ScreenUpdating = False
    Cells(5, 1).CurrentRegion.Offset(1).ClearContents
    For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count, Range("m3"))
        If Sheets(i).Name <> "ÇáÈÍË" Then
            lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets(Sheets(i).Name).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _
                                                                    CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1)
            Cells(lr1, 1).Resize(, 12).Delete
            lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If lr1 <> lr2 Then
                Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = Sheets(i).Name
            End If: End If
    Next
    Range("I10").Select
    Application.ScreenUpdating = True
End Sub

 

[محي الدين ابو البشر]

عند كتابة رقم الشيت يقتصر البحث في الشيت المكتوب فقط 

Updated

Sub Test()
    Dim lr1, lr2
    Dim i
    Application.ScreenUpdating = False
    Cells(5, 1).CurrentRegion.Offset(1).ClearContents
    For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count, Range("m3"))
    If Range("m3") <> "" Then i = Range("m3").Value + 1
        If Sheets(i).Name <> "ÇáÈÍË" Then
            lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets(Sheets(i).Name).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _
                                                                    CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1)
            Cells(lr1, 1).Resize(, 12).Delete
            lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If lr1 <> lr2 Then
                Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = Sheets(i).Name
            End If: End If
    Next
    Range("I10").Select
    Application.ScreenUpdating = True
End Sub

 

[هادي أحمد]

بتظهر الرسالة ديه 

يتضمن نطاق الاستخراج اسم حقل مفقود أو غير صحيح

وبيتم تحديد الجزء الاعلى

 

[هانى محمد]

بارك الله فيك أستاذ محي كود ممتاز ويعمل بكفاءة

هادي أحمد الكود تمام وشوف بنفسك يعمل بكل كفاءة