مختار حسين محمود

أشكرك على ثناءك على الكود ودعاءك لى

الحمد لله الذى وفقنى الى ما تريد  تحياتى

السلام عليكم و رحمة الله وبركاته

اليك الملف التالى عله يفى بالغرض

الكود ينجم عنه ملف باسم (Debits ) يعنى الديون أو الأقساط المستحقة + تاريخ اليوم والساعة والثانية التى تم فيها انشاء الملف

الكود طويل نوعا ما لكنه سريع و يحقق ما تصبو اليه  واذا توصلت الى كودا  أسرع وأبسط سأرفعه لك 

ملحوظه مهمة : فى الكود يتم انشاء شيت جديد باسم الديون بنجمع فيه الديون  هذا الشيت يتم نسخه الى الملف الجديد ثم يحذف

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

نمودج من اصناف Molhtar 1.rar

السلام عليكم ورحمة الله وبركاته

الى كل كل الأخوة  الكرام فى المنتدى كل عام وأنتم بخير

أخى الكريم النطاق يتحرك الى أعلى بسبب حذف صف

لكى يبقى النطاق ثابتا نزود صف بدلا من المحذوف فوق النطاق مباشرة ( تم تعديل الكود )

3حذف و لصق.rar

أشكرك

اعذرنى على عدم استيعاب طلب الاخير

الحمد لله أنك توصلت الى مبتغاك  تحياتى

جرب

دوائر مختار 2.rar

شوية ايضاح

حسب ما فهمت من المخطط هل تريد أن تقول

أن الدرجة الصغرى  لو أقل من 10 يبقى تحاط الخلايا التى قيمتها أقل من قيمة الدرجة الصغرى ( رأس العمود ) بدوائر

واذا كانت الدرجة الصغرى  أكبر من 10 يبقى تحاط الخلايا التى قيمتها أقل من 10 بدوائر

ما هو التعديل المطلوب ؟

السلام عليكم

بدون تنسيق  شرطى و بدون الكود فى الملف الاصلى

تفضل الملف بكود جديد وأسهل من  الاصلى عسى أن يكون المطلوب

دوائر مختار.rar

أخى الغالى عبدالعزيز البسكرى

و أنا  أسعد لسعادتك  و يشرفنى مرورك و تعليقاتك و ملاحظاتك على موضوعاتى

تقبل منى كل التحية والتقدير لشخصكم الكريم

أخى صالح

 يشرفنى مرورك و تعليقاتك و ملاحظاتك جزاك الله كل خير

أستاذ جمال  

 اسم الشيت  فى ملفك به مسافة فارغة  لم تدرج فى الكود قد يكون هذا هو السبب

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

بيان وقتى 3.xls

السلام عليكم ورحمة الله وبركاته

أخى و أستاذى الفاضل محمد حسن

الحمد لله بالفعل حضرتك خطوت ولكن خطوات وثابة

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

تحياتى و مزيد  من التقدم والرقى و الى الأفضل ان شاء الله

وأنت فاتح ملف الاكسل اضغط  المفتاحين  Alt  + F11   معا هتلاقى نافذة محرر الاكواد 

من فوق هتلاقى قوائم من ضمنها قائمة insert  اختر  مديول  هتفتح معاك صفحة بيضاء

هذه الصفحة هى نافذة محرر الاكواد  بنكتب و نلصق فيها الاكواد 

جرب الملف ده   هتلاقى جواه  كود حفظ الشيت كملف جديد 

بيان وقتى 2.rar

طبقا لما طلبته تفضل

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

الكود سوف يحفظ  الشيت رقم 2  كملف جديد كما طلبت فى المرفق  فى البارتش D  

وأضفت لك الوقت ( تاريخ اليوم والساعة والثانية ) لاسم الملف عشان تفرق بين الملفات الناتجة  بالتاريخ

Option Explicit

Sub Auto_Open()
Dim MyTime As Date
MyTime = TimeSerial(10, 0, 0)     ' بداية عمل الكود بعد فتح الملف
Application.OnTime MyTime, "ExportSpecificSheet"
End Sub

Sub ExportSpecificSheet()
    Dim WB As Workbook, WS As Worksheet, fName As String
    Set WS = ThisWorkbook.Sheets("Sheet2") ' حدد اسم الشيت
    fName = "D:\" & "نسخة من البيان الوقتى" & "(" & Format(Now, "dd-mm-yyyy hhmmss") & ")" & ".xlsx"   ' حدد اسم و مسار وامتداد الملف
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        If WB Is Nothing Then
            WS.Copy
            WS.UsedRange.Value = WS.UsedRange.Value
            Set WB = ActiveWorkbook
            With WB
                .SaveAs Filename:=fName
                .Close True
            End With
        End If
        Set WS = Nothing
        Set WB = Nothing
     Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Your's Sheet Exported Now ...", 64
End Sub

أخبرنى بالنتيجة   تحياتى

أنا مجرب من غير ما تقول

تأكد من أن ملفات الريجسترى فى نفس مسار ملف الاكسل  يعنى معاه أو جنبه داخل مجلد واحد

بعد اذن أستاذى ياسر

حسب ما فهمت منك :

للمقارنة بين رقمين  فى خليتين و ليكن J6  و  K6    فى أى خلية ضع المعادلة : ناتج المعادلة الفرق بين الرقمين

=IFERROR(ABS( J6-K6 );"")

أو  المعادله دى  لوكنت عايز تم اذا كان الفارق صفر أو ما زال تخت التشغيل اذا كان الفارق لا يساوى صفرا

=IFERROR(IF(ABS($J6-$K6 )<>0;"ما زال تحت التشغيل";"تم");"")

جزاك الله كل خير  على الموضوع و الشرح بالصور

تمت التجربة بطريقتك و نجحت بارك الله فيك

بارك الله فيك أخى سليم  وجزاك خيرا

و اثراء للموضوع  أخى محمد أضف مجموعة أسماء  فى النطاق الذى حددته

وجرب الكود التالى :

Option Explicit
Sub MokhtarRownumber()
 Dim SNem As String, LR As Long, X As Long
 SNem = "محمد"
 With ActiveSheet
         LR = .Cells(.Rows.Count, "B").End(xlUp).Row
         For X = 4 To LR
             If .Cells(X, "B").Value = SNem Then
                .Cells(X, "C").Value = Split(.Cells(X, "B").Address(1, 0), "$")(1)
             End If
         Next X
 End With

End Sub

مشكور  أخى ياسر  على الموضوع

أنا عندى البرنامج ده و بستخدمه على ملفات xls فقط  ولم يفلح مع xlsm أو xlsb

لم أجرب طريقتك  لأنى غير قادر على تحميل الشرح  مش عارف ليه

يا ريت باختصار  طريقتك  الخاصة فى صورة نقاط 1 2 3 باخنصار     تحياتى

أخى عبدالعزيز عذرا   الموضوع شدنى ونسانى أسلم عليك لعلك بخير أنت وكل أهل بسكرة   تحياتى

مع أنى لا أحبذ تخفيض درجات الأمان الا فى الضرورة   الضرورة القصوى  جرب الكود التالى  يوضع فى حدث الملف

Private Sub Workbook_Open()

CreateObject("WScript.Shell").Run "%WinDir%\Regedit.exe /s ""ActiveWorkbook.Path & \zaMachineSecurityLevel.reg"""
CreateObject("WScript.Shell").Run "%WinDir%\Regedit.exe /s ""ActiveWorkbook.Path & \zaUserSecurityLevel.reg"""

End Sub

أستاذ جمال سعد أهلا بك

بداية نرجو منك تغيير اسمك الى اللغة العربية  و ثانيا طلبك يحتاج بعض الايضاح ليتمكن الأعضاء من مساعدتك

مطلوب منك : مرفق أو ملف توضح فيه اسم الصفحة التى تريد حفظها + الوقت الذى تريد فيه بدء الحفظ  و ذلك يكون بعد فتح الملف  + مكان أو مسار الحفظ

تحياتى

بارك الله فيك أخى ابراهيم

حل آخير جربه   وهو الغاء ظهور الرسالة أصلا والاكتفاء بازالتها

استبدل السطرين  دول فى كود الليبل

kh_Err:
    If Err Then MsgBox "Err.Number : " & Err.Number: Err.Clear

بالسطرين دول

kh_Err:
    If Err Then Err.Clear

مع خالص تقديرى

أخى رجب  و حدود الدول  أيضا

أخى ابراهيم جرب تحط اسم الملف فى متغير

dim wb as workbook

set wb = activeworkbook

وفى نهاية الكود

On Error GoTo 1

:1

Application.Goto wb

أخى وأستاذى ياسر 

يبدو أن النسيان مشى من عند أخى رجب و شرّف عندى  و تعمل ايه فى الاستسهال 

مع تقديرى و شكرى  ( ابن عم تحياتى ) 

بارك الله فيكما  أستاذى  رجب وأستاذى ياسر و جزاكما خيرا

أخى ابراهيم الكود توقف لأنك طبقته على ملف جديد  مش الملف 1  المرفق فى مشاركتك الاولى

Activate .("اسم الملف")  Workbooks   لتنشيط الملف 

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

لذا عند الضغط على زر غلق الفورم x  لايدرى اكسل أيهما يغلق ( الفورم أم الملف الجديد النشط )

ولذلك يحدث هذا الخطأ وبناء عليه لجأت الى تنشيط الملف الأصلى مرة أخرى   والله أعلى وأعلم

جرب كده

Sub CreateSheets_w_name()
    Dim ws As Worksheet
    Dim ra As Range
    Dim name As Range
    Set ws = Worksheets("اسماء ورقات العمل")
    With ws
    Set ra = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    End With
    Dim NW As Workbook
    Set NW = Workbooks.Add
    
    On Error Resume Next
    For Each name In ra
        If Len(Trim(name.Value)) > 0 Then
            If Len(Worksheets(name.Value).name) = 0 Then
                NW.Worksheets.Add(After:=NW.Worksheets(Worksheets.Count)).name = name.Value
            End If
        End If
    
    Next name
    On Error GoTo 1
1:
Workbooks("1").Activate

    
End Sub