كيف اجعل الكود يبحث ويفرز حسب التاريخ في جميع الاوراق الحالية والتي سوف تضاف

[ابوعلي الحبيب]

السلام عليكم
يا كرام 

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

---------------
وقام الاستاذ سليم مشكور بعمل كود ولكن يحتاج تعديل 
---------------
المطلوب

ان ياخذ التاريخ من العامود َQ فقط
في جميع الاوراق وهو المهم 
 اما قبل التاريخ او بعده
وحذفت عامود ((من ))لكي لا يسبب اشكال

المشاكلة الان هي 

بعد تعديل التاريخ  
في خلية التاريخ من الى  C1 C2
 لا يظهر شي 
حتى اذا كان التاريخ قصير تظهر نتيجة مختلفة
 
امل المساعدة 
 ولكم جزيل الشكرررررر
مرفق ملف 

 

جلب حسب التاريخ.xlsm

تم تعديل فبراير 4, 2019 بواسطه ابوعلي الحبيب

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

تعديل على الماكرو

Option Explicit
Sub Give_Data()
'If ActiveSheet.Name <> "DATA" Then Exit Sub
Dim My_Sh As Worksheet
Dim Rg_to_Copy As Range
Dim cell_to_Copy As Range
Dim m%: m = 5
Dim t%, x%
Dim start_date As Date: start_date = Sheets("DATA").[c1]
Dim final_date As Date: final_date = Sheets("DATA").[c2]
With Sheets("DATA")
   .Range("a5:y" & Rows.Count).ClearContents
   .Range("a5:y" & Rows.Count).Interior.ColorIndex = 2
   For Each My_Sh In Worksheets
     If My_Sh.Name = "DATA" Or My_Sh.Name = "ملاحظات" Then Exit Sub

       Set Rg_to_Copy = My_Sh.Range("a6").CurrentRegion.Offset(1).Columns(1).Cells
               For Each cell_to_Copy In Rg_to_Copy
            cell_to_Copy.Resize(, 24).Interior.ColorIndex = 2
          
            If cell_to_Copy.Offset(, 16) >= start_date _
              And cell_to_Copy.Offset(, 16) >= final_date Then
              .Range("a" & m).Resize(, 24).Value = _
              cell_to_Copy.Resize(, 24).Value
               cell_to_Copy.Resize(, 24).Interior.ColorIndex = 6
              m = m + 1
              t = t + 1
            End If
            Next
            '=======================
        If t <> 0 Then
           x = .Cells(Rows.Count, 1).End(3).Row
          .Cells(x + 1, 6) = "حصيلة الورقة :" & My_Sh.Name
          .Cells(x + 1, 1).Resize(, 25).Interior.ColorIndex = 6
           m = x + 3
          Else
        End If
             t = 0
                    '=================

   Next
End With
End Sub

 

[ابوعلي الحبيب]

اشكرك استاذي الكريم 
سليم حاصبيا 
على تفاعلك

المشكلة الان

النتيجة 
نتيجة خاطئة
شاهد الصوره 

تظهر بغير التواريخ المحدده 

حيث حددت شهر 

يجلب مده طويله 

**كذالك لا يجلب من كل الاوراق 
جزاك الله خير
 

[جمعه صالح]

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

جلب حسب التاريخ.xlsm

[ابوعلي الحبيب]

الأستاذ الفاضل  / سليم حاصبيا
ماشاء الله تبارك الله عليك

بالفعل هذا هو المطلوب بالضبط

كل الشكر والتقدير لك

ولجميع من ساعدني في هذا المنتدى الرائع

ولو اثقلت عليك 

هل يمكن اضافة الارتباط التشعبي مع جلب البيانات لسهوله للعوده لصفحه

ارتباط ل اسم الورقه

واكررررررر لك الشكر والعرفان 

واشكر اخي جمعه صالح

على تفاعلك

 

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

لا مستحيل عند الاكسل

الكود بعد تعديله ليعطي ارتباط تشعبي

Option Explicit
Sub Give_Data()
If ActiveSheet.Name <> "DATA" Then Exit Sub
Dim My_Sh As Worksheet
Dim Rg_to_Copy As Range
Dim cell_to_Copy As Range
Dim m%: m = 5
Dim t%, x%
Dim start_date As Date: start_date = Sheets("DATA").[c1]
Dim final_date As Date: final_date = Sheets("DATA").[c2]
With Sheets("DATA")
   .Range("a5:y" & Rows.Count).ClearContents
   .Range("a5:y" & Rows.Count).Interior.ColorIndex = 2
   For Each My_Sh In Worksheets
     If My_Sh.Name = "DATA" Or My_Sh.Name = "ملاحظات" Then GoTo 1

       Set Rg_to_Copy = My_Sh.Range("a6").CurrentRegion.Offset(1).Columns(1).Cells
               For Each cell_to_Copy In Rg_to_Copy
            cell_to_Copy.Resize(, 24).Interior.ColorIndex = 2
                      If cell_to_Copy.Offset(, 16) >= start_date _
              And cell_to_Copy.Offset(, 16) <= final_date Then
              .Range("a" & m).Resize(, 24).Value = _
              cell_to_Copy.Resize(, 24).Value
               cell_to_Copy.Resize(, 24).Interior.ColorIndex = 6
              m = m + 1
              t = t + 1
            End If
            Next
            '=======================
        If t <> 0 Then
           x = .Cells(Rows.Count, 1).End(3).Row
          .Cells(x + 1, 6) = "حصيلة الورقة :" & My_Sh.Name
          .Cells(x + 1, 1).Resize(, 24).Interior.ColorIndex = 6
          '===================
           .Cells(x + 1, 10).Hyperlinks.Add Anchor:=.Cells(x + 1, 10), Address:="", _
           SubAddress:=My_Sh.Name & "!A1", TextToDisplay:="Go To: " & My_Sh.Name
          .Cells(x + 1, 10).Font.Size = 16
          '===================
           m = x + 3
          Else
        End If
             t = 0
                    '=================
1:
   Next
End With
End Sub

الملف جاهز

 

New_جلب حسب التاريخ.xlsm

[ابوعلي الحبيب]

الأستاذ الفاضل  / سليم حاصبيا

 انت مبدع

ماشاء الله تبارك الله عليك

كل الشكر والتقدير لك

الله يجزاك الجنة ووالديك

ولجميع من ساعدني في هذا المنتدى الرائع

 

تم تعديل فبراير 4, 2019 بواسطه ابوعلي الحبيب