وعليكم السلام ورحمة الله وبركاته
الكود
Sub CreateBackup()
Dim wb As Workbook
Dim folderPath As String
Dim fileName As String
Dim fileExtension As String
Dim backupName As String
Dim backupNumber As Integer
Dim fso As Object
Dim file As Object
Set wb = ThisWorkbook
folderPath = wb.Path & "\"
fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
fileExtension = Mid(wb.Name, InStrRev(wb.Name, "."))
Set fso = CreateObject("Scripting.FileSystemObject")
backupNumber = 0
For Each file In fso.GetFolder(folderPath).Files
If InStr(file.Name, fileName) = 1 And InStr(file.Name, fileExtension) > 0 Then
Dim currentNumber As Integer
On Error Resume Next
currentNumber = CInt(Mid(file.Name, Len(fileName) + 1, InStrRev(file.Name, fileExtension) - Len(fileName) - 1))
On Error GoTo 0
If currentNumber > backupNumber Then
backupNumber = currentNumber
End If
End If
Next file
backupName = folderPath & fileName & (backupNumber + 1) & fileExtension
wb.SaveCopyAs backupName
MsgBox "تم إنشاء نسخة احتياطية باسم: " & vbCrLf & backupName, vbInformation, "نسخة احتياطية"
End Sub
الملف
Ehab.xlsb