ابوعلي الحبيب قام بنشر فبراير 4, 2019 قام بنشر فبراير 4, 2019 (معدل) السلام عليكم يا كرام لدي ملف في كود بحث او فرز حسب التاريخ كيف اجعله يبحث ويحضر من جميع الاوراق الحالي والتي سوف تضاف في المستقبل بنفس التنسيق --------------- وقام الاستاذ سليم مشكور بعمل كود ولكن يحتاج تعديل --------------- المطلوب ان ياخذ التاريخ من العامود َQ فقط في جميع الاوراق وهو المهم اما قبل التاريخ او بعده وحذفت عامود ((من ))لكي لا يسبب اشكال المشاكلة الان هي بعد تعديل التاريخ في خلية التاريخ من الى C1 C2 لا يظهر شي حتى اذا كان التاريخ قصير تظهر نتيجة مختلفة امل المساعدة ولكم جزيل الشكرررررر مرفق ملف جلب حسب التاريخ.xlsm تم تعديل فبراير 4, 2019 بواسطه ابوعلي الحبيب
سليم حاصبيا قام بنشر فبراير 4, 2019 قام بنشر فبراير 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 1
ابوعلي الحبيب قام بنشر فبراير 4, 2019 الكاتب قام بنشر فبراير 4, 2019 اشكرك استاذي الكريم سليم حاصبيا على تفاعلك المشكلة الان النتيجة نتيجة خاطئة شاهد الصوره تظهر بغير التواريخ المحدده حيث حددت شهر يجلب مده طويله **كذالك لا يجلب من كل الاوراق جزاك الله خير
جمعه صالح قام بنشر فبراير 4, 2019 قام بنشر فبراير 4, 2019 الله ينور استاذ سليم الكود الثاني تمام اتفضل استاذ ابوعلي الملف بعد اضافة تعديل الكود من الاستاذ سليم جلب حسب التاريخ.xlsm 2
ابوعلي الحبيب قام بنشر فبراير 4, 2019 الكاتب قام بنشر فبراير 4, 2019 الأستاذ الفاضل / سليم حاصبيا ماشاء الله تبارك الله عليك بالفعل هذا هو المطلوب بالضبط كل الشكر والتقدير لك ولجميع من ساعدني في هذا المنتدى الرائع ولو اثقلت عليك هل يمكن اضافة الارتباط التشعبي مع جلب البيانات لسهوله للعوده لصفحه ارتباط ل اسم الورقه واكررررررر لك الشكر والعرفان واشكر اخي جمعه صالح على تفاعلك
سليم حاصبيا قام بنشر فبراير 4, 2019 قام بنشر فبراير 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 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 2 1
ابوعلي الحبيب قام بنشر فبراير 4, 2019 الكاتب قام بنشر فبراير 4, 2019 (معدل) الأستاذ الفاضل / سليم حاصبيا انت مبدع ماشاء الله تبارك الله عليك كل الشكر والتقدير لك الله يجزاك الجنة ووالديك ولجميع من ساعدني في هذا المنتدى الرائع تم تعديل فبراير 4, 2019 بواسطه ابوعلي الحبيب 2
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.