اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


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

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


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

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

المطلوب

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


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


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

امل المساعدة :fff:
 ولكم جزيل الشكرررررر
مرفق ملف 


 

جلب حسب التاريخ.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 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

 

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

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

المشكلة الان

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

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

حيث حددت شهر 

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

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

 

252526.JPG

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

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

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

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

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

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

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

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

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

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

على تفاعلك

 

2333333333.JPG

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

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

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

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

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

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

 انت مبدع

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

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

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

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

 

تم تعديل بواسطه ابوعلي الحبيب
  • Like 2
رابط هذا التعليق
شارك

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

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



سجل دخولك الان
×
×
  • اضف...

Important Information