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

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

قام بنشر (معدل)

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


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

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

المطلوب

ان ياخذ التاريخ من العامود َ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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information