اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by محي الدين ابو البشر,

الردود الموصى بها

جرب هذا الكود


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

  • Like 3
رابط هذا التعليق
شارك

السلام عليكم

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

ولو عايز اضيف شيت او احذف شيت بس من الأول لاني حاولت احذف الشيت رقم 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

 

  • Like 1
رابط هذا التعليق
شارك

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

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


 

  • Like 2
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information