إنشاء نسخة احتياطي من المصنف (حفظ تلقائي) كل فترة زمنية محددة Backup Automatically Every 15 Seconds

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

أقدم لكم كود يقوم بإنشاء نسخة احتياطية من المصنف كل 15 ثانية ، وذلك تحسباً لحدوث مشاكل مثل الانقطاع المفاجيء للتيار الكهربائي أو كنوع من الحيطة والحذر كي يكون لديك أكثر من نسخة من ملفك وخصوصاً إذا كان الملف مهم للغاية

الكود يقوم بإنشاء النسخة الاحتياطية في نفس مسار المصنف الحالي في مجلد باسم Test ، ويتم إنشاء المجلد بشكل تلقائي إذا لم يكن موجود ، ويمكنك تغيير مسار الحفظ التلقائي ، ويمكنك تغيير اسم المجلد المطلوب حفظ النسخ الاحتياطية فيه ، كما يمكنك تغيير الفترة الزمنية المطلوبة لعملية الحفظ التلقائي (الكود مشروح بالتفصيل كي يسهل عليك مهمة التعديل عليه)

وأخيراً إليكم الكود ، وهو مكون من كود يوضع في موديول عادي بهذا الشكل

Sub Create_Backup()
    'تعريف المتغيرات
    Dim strDate As String, strTime As String, directoryName As String

    'تنسيق التاريخ
    strDate = Format(Date, "DD-MM-YYYY")

    'تنسيق الوقت
    strTime = Format(Time, "hh.mm.ss")

    'إلغاء خاصية رسائل التنبيه
    Application.DisplayAlerts = False

        'بدء التعامل مع المصنف النشط
        With ActiveWorkbook
            On Error Resume Next
                '[Test] المسار الذي سيتم حفظ النسخة فيه وهو نفس مسار المصنف الحالي في مجلد باسم
                directoryName = ThisWorkbook.Path & "\Test\"
        
                'إنشاء المجلد الذي سيتم وضع النسخ الاحتياطية فيه إذا لم يكن موجود
                MkDir directoryName
            On Error GoTo 0
    
            'حفظ نسخة من المصنف بالتاريخ والوقت الحاليين
            .SaveCopyAs Filename:=directoryName & strDate & "_" & strTime & "_" & .Name
        End With

    'إعادة تفعيل خاصية رسائل التنبيه
    Application.DisplayAlerts = True

    'سطر يقوم بتنفيذ الماكرو مرة أخرى بعد الوقت المحدد في السطر
    Application.OnTime Now + TimeValue("00:00:15"), "Create_Backup"
End Sub

والجزء الثاني من الكود يوضع في حدث المصنف بهذا الشكل

Private Sub Workbook_Open()
    'بعد مرور الوقت المحدد في السطر [CreateBackup] يقوم هذا السطر بتنفيذ الماكرو المسمى
    Application.OnTime Now + TimeValue("00:00:15"), "Create_Backup"
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء