الـعيدروس

اخي طلبك غير واضح نوع ما هل تريد الكود الذي يبداء UDI في عمود C التي تاريخ إصدارها (فى العمود B) أقل من تاريخ اليوم يقوم بعمل تقرير لها في ورقة اخرى اذا هذا المفهوم صحيح ماهي الاعمدة التي تريد عملها في التقرير ارجو سرعة الرد تحياتي

السلام عليكم الاخ الفاضل MGS وهذا حل اخر نفس الكود وعليه تعديلات طفيفة الاسم المراد نسخة انقر على الزر صندوق البحث اشر على الصف المطلوب نسخة وصندوق الورقة اشر على اي خلية فيها اسم الورقة المعنية وموافق وراح ينسخة للورقة المختارة هذا الكود Sub Find1_alidroos() Dim rng As Range Dim sh As Worksheet Dim sh1 As Worksheet Dim go As String Dim ali As String On Error Resume Next Application.DisplayAlerts = False Set rng = Application.InputBox(Prompt:= _ "ادخل كلمة البحث تحديد بالماوس", _ Title:="سبحان الله وبحمدة سبحان الله العظيم", Type:=8) On Error GoTo 0 Application.DisplayAlerts = True If rng Is Nothing Then Exit Sub Else ali = Application.InputBox("ادخل اسم الورقة المراد لصق البيانات فيها", "") If ali = "False" Or ali = vbNullString Then Exit Sub rng.Select Set sh1 = Sheets(ali) Application.ScreenUpdating = False Application.EnableEvents = False sh1.Select ish = Range("a15000").End(xlUp).Row + 1 rng.Offset(0, 0).Resize(1, 4).Copy Destination:=sh1.Range("a" & ish) MsgBox "تمت عملية نسخ النتيجة بنجاح ", vbInformation, "" End If Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True End Sub وهذا مرفق 15_alidroos.rar

السلام عليكم الاستاذ القدير الحسامي حفظك الله عمل رائع ومميز ماشاء الله عليك وهذه اضافة اذا لزمت لقراء اسماء الشيتات في الليست Private Sub UserForm_Initialize() Dim lis_ALI As Integer For lis_ALI = 1 To ActiveWorkbook.Sheets.Count UserForm4.ListBox1.AddItem ActiveWorkbook.Sheets(lis_ALI).Name Next End Sub

استاذ الحسامي كل اكوادك رائعة انت محترف بمعنى الكلمة زادك الله من علمة وفضلة تقبل مروري

هذا ماتعلمناه منكم استاذي عبدالله المجرب وفقك الله

حبيبي سعد عابد تسلم هذا بعض ماعندكم وفقك الله

السلام عليكم تم عمل كود كالتالي : تبحث عن الاسم وبعدها تكتب اسم الورقة المراد لصق البيانات فيه هذا هو الكود Sub Find_alidroos() Dim rng As Range Dim sh As Worksheet Dim sh1 As Worksheet Dim go As String Dim ali As String On Error Resume Next go = Application.InputBox("ادخل كلمة البحث", "") If go = "False" Or go = vbNullString Then Exit Sub With Range("A2:A25000") Set rng = .Find(go, , LookIn:=xlValues, lookat:=xlWhole) If rng = True Then MsgBox "غير موجود الاسم في قاعدة البيانات او تأكد من حالة الأحرف" Exit Sub Else ali = Application.InputBox("ادخل اسم الورقة المراد لصق البيانات فيها", "") If ali = "False" Or ali = vbNullString Then Exit Sub rng.Offset(0, 0).Resize(1, 4).Select Selection.Copy Set sh1 = Sheets(ali) Application.ScreenUpdating = False Application.EnableEvents = False sh1.Select ish = Range("a15000").End(xlUp).Row + 1 Range("a" & ish).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End If End With MsgBox "تمت عملية نسخ النتيجة بنجاح ", vbInformation, "" Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True End Sub وهذا المرفق ان شاء الله يفيدك 14_alidroos.rar

الاستاذ عبدالله المجرب عيني عليك باردة مبدع كالعادة تسلم

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

السلام عليكم اخي باسم اهلا بك منور يالغالي وين ايامك يارجل يامطول الغيبات وين الغنايم لك وحشة جرب المرفقات علا يكون زبط تفضل ap_alidroos.rar

السلام عليكم الاستاذ القدير والمعلم الكبير احمد حمور ابو عبدالله جزاك الله خير على تفاعلك الاخ الفاضل انا عامل حظر تجوال للأخطاء ارجو من الله ان يزبط معاك جرب المرفق DATA_NO_ERROR.rar

الاستاذ القدير عبدالله المجرب تسلم على هذا المرور العطر والتشجيع وبالنسبة لدالة ROUND استخدمتها غير مجدية بعض الخلايا لاتجبر الكسر عند كثر البيانات هذا من تجربة

اسف لم اوضح استخدامها هكذا ABU_NSSAR_GABR = (الخلية التي فيها الرقم)

الله يبارك فيك استاذ ياسر الحافظ مرورك اسعدني تسلم ان شاء الله نخدم هذا المنتدى بقدر المستطاع وفقك الله

لا حوول ياريت ادري كيف تعدي عليا مواضيع مااوصل الا متأخر الحبيب الغالي سعد عاااابد :fff: تسلم على هذه الدرر ماشاء الله عليك الى الامام يامبدع

السلام عليكم سبق وان طرحت موضوع للعملية التالية اذا كان الرقم 1.49 يكسر الجبر 1 واذا كان الرقم 1.51 يصير 2 فتوصلت الى كود دالة ارجو ان يفيدكم ومن لدية فكرة يظيفها على الكود تفضلو هذا الكود Function ABU_NSSAR_GABR(pValue As Double) As Double '=================================================== 'دالة_ماتحت_النص_تكسر_الجبر_ومافوق_النص_تضيف_عدد_صحيح '=================================================== Dim ali As Long Dim adad As Double ali = Int(pValue) adad = pValue - ali If adad < 0.5 Then ABU_NSSAR_GABR = ali Else ABU_NSSAR_GABR = ali + 1 End If End Function تحياتي

السلام عليكم الاستاذ القدير الحسامي فكرة جميلة جدا جزيت خيرا الاخ صاحب الموضوع اطلع على المرفق كود الاستاذ الحبيب الحسامي اضفتة في الثلاثه الشيتات فرضا ان كل موظف بياناته في شيت محدد ظهور الصوره بالنسبه1.rar

اخي جربت ملفك اكثر من 5 اجهزة والله شغال زي الحلاوى والاستاذ احمد حمور ابو عبدالله برضه شغال عنده يعني جهازك فيه شي حاول انت من جهاز اخر وابلغني هل عمل معاك ام لا عشان تعرف ان الاكواد مافيها شي ان شاء الله واي اضافات او تعديل انا موجود تحياتي

ابشر

انظر المرفق كود للاستاذ خبور خير حفظة الله 13.rar

اخي سوف احاول اعمل حل يتوصل لما تريد بأسلوب اخر تحياتي

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

اخي الفاضل خلية T1 معيار اذا كان مكتوب فيها True لايعمل استرجاع ماقبل الحركة الاخيره في الخليه واذا كان مكتوب فيها False ينشط كود الاسترجاع والله اعلم

جزاكم الله خيرا اساتذتي وهذا كود مختصر اخر لاثراء الموضوع تحطه في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("b2:b100")) Is Nothing Then Target(1, 0).Value = Time End Sub

الاستاذ الحبيب سعد عابد جزاك الله خير على كلماتك الطيبه موفق ياخلوق