مشكور جدا أستاذى الفاضل على هذه الملحوظة

ولحل هذه المشكلة مؤقتا سريعا لحين التعديلات عليها

قم بالوقوف فى الخلية التى بها كلمة ( أم المؤمنين ) ومن أدوات الأوفيس أعلى من قائمة Home

اجعل لون الخط أبيض فلا تظهر فى الطباعة

 
مبروك أستاذ / حسونة

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

تقبل تحياتى

 
اتفضل يا أستاذ محمد عبد السلام

لك ما طلبت ... وملحوظة هامة لابد أن يكون اسم المجلد الذى ستجعله فى المكان المخصص  D:  هو نفسه الموجود فى الكود ( تأكد من تطابق الاسمين)

فى هذا الجزء من الكود

ActiveWorkbook.SaveCopyAs Filename:="D:Backup"

 
 لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

 اتفضل أخى الكريم

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

 
أستاذ / محمد عبد السلام

الرجاء جعل الموضوع واحد وعدم إفراد طلب منفصل لكل جزئيه من المشروع لكى يمكن تتبعه من السادة الأعضاء بسهولة

واتفضل بعد إذن الأستاذ / حسنونه

الكود كامل بطلب جزئية ( رسالة التنبيه بالترحيل من عدمه )  ....... ده طلب كان موضوع  +  جزئية ( فصل الاسم عن التاريخ فى عمودين منفصلين ) و ....... ده كان طلب موضوع آخر ( بالرغم من أن المشروع واحد .. لعلك فهمت ما أقصد

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean



Private Sub CommandButton1_Click()



    Dim wx As Workbook, ws As Worksheet, wss As Worksheet, wss2 As Worksheet, Nam, lr As Long

    Set wx = ThisWorkbook

    Set ws = wx.Sheets("invoice")

    Set wss = wx.Sheets("sheet1")

    Set wss2 = wx.Sheets("sheet2")

    

    Application.ScreenUpdating = False

    Application.EnableEvents = False

    Application.DisplayAlerts = False

'-------------------------------------------------

 MD = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _

      , vbYesNo + vbQuestion + vbDefaultImage30 + vbApplicationModal, "أكاديمية الصقر للتدريب")

  If MD = vbNo Then

    Exit Sub

       End If

'-------------------------------------------------

    lr = wss.Range("a" & Rows.Count).End(xlUp).row + 1

        With ws

        

            Nam = .Range("e5")

            Da = Format(Now(), "dd-mm-yyyy hh.mm.ss")

            MakeSureDirectoryPathExists ThisWorkbook.Path & "\backup\"

            ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\backup\" & Nam & ".xlsm"

            '=========================================

            If ws.[f5].Text = "اجل" Then

                wss.Range("a" & lr).Value = Nam

                wss.Range("a" & lr).Font.Color = 255

                wss.Range("B" & lr).Value = Da

                wss.Range("C" & lr).Value = "اجل"

                

          Else: wss.Range("a" & lr).Value = Nam

                wss.Range("B" & lr).Value = Da

                wss.Range("C" & lr).Value = "نقدي"

          End If

            If ws.[f5].Text = "اجل" Then

                wss2.Range("a" & lr).Value = Nam

                wss2.Range("a" & lr).Font.Color = 255

                wss2.Range("B" & lr).Value = Da

                wss2.Range("C" & lr).Value = "اجل"

          Else: wss.Range("a" & lr).Value = Nam

                wss2.Range("B" & lr).Value = Da

                wss2.Range("C" & lr).Value = "نقدي"

            End If

            '========================================

            '                 ActiveWorkbook.Close False

        End With

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    Application.EnableEvents = True

        MsgBox "تم حفظ نسخة باسم " & Nam & " ", vbInformation

End Sub


 

 

 
بارك الله فيك أخى الغالى / حســـونه

ما شاء الله شعلة نار سرعة الاجابة و روعة أداء

جزاك الله خيرا

-----------

وبعد اذنك تلبية لأخونا  محمد عبد السلام  ـ

الجزء الأخير من الطلب للسؤال بوضع رسالة تنبيه بالاختيار من الترحيل من عدمه

أستاذ / محمد 

قبل هذا السطر الموجود بالكود

lr = wss.Range("a" & Rows.Count).End(xlUp).row + 1

 

قم بإضافة هذه الأسطر لرسالة التنبيه

MD = MsgBox(" هل تريد الترحيل الى Sheet1  ؟", vbYesNo + vbQuestion + vbDefaultImage30 + vbApplicationModal, "أكاديمية الصقر للتدريب")

  If MD = vbNo Then

    Exit Sub

       End If


 

 جزاكم الله خيرا استاذ ياسر

على هذه الروائع

 

 مشكور جدا أستذانا الكبير / سليم

على اثراء الموضوع بحلول رائعة دائما نستفيد منها

جزاكم الله خيرا

 
أستاذ / أيوب

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

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

وفوق كل هذا ـ لا تنسى وضع الكود التالى فى حدث ورقة العمل Liste
 

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = Range("O2").Address Then

         Calling_Data

    End If

End Sub

 وبارك الله فيكم أخى الحبيب / ياسر ومشكور دائما على مروركم العطر علينا

الأستاذ / أحمد شريف

الحمد لله الذى أتم علينا نعمه بحل المشكلة

 
اتفضل استاذى الكريم

الملف المرفق تم عمل يوزرفوم ادخال البيانات فى النطاق المطلوب بعد اختياره من القائمة الموجودة بالفورم

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

 
جزاكم الله خيرا أستاذ / ياسر

على كل ما تقدمه لنا

ونسأل الله العلى القدير أن ينعم عليكم بصلاح الحال وراحة البال