عمل نسخه من شيت

[gamal saad]

برجاء تفعيل الكود دا على ملف الاكسل المرفق

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

 

بيان وقتى.xlsx

[محمد هشام.]

 

 

Private Sub Workbook_Open()   'بداية عمل الكود بعد فتح الملف
'قم ببتعديل الوقت بما يناسبك
Application.OnTime Now + TimeValue("00:00:10"), "ExportSpecificSheet"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Sub ExportSpecificSheet()
    'حدد   مسار الملف
    Const FolderPath As String = "D:\"
    'اسم الملف
    Const FileName As String = "نسخة من البيان الوقتى"
    'حدد اسم الشيت
    Const SheetName As String = "Sheet2"
   
    If Evaluate("Isref('" & SheetName & "'!A1)") Then

    On Error Resume Next
    Workbooks(FileName).Close
    On Error GoTo 0
    
With ThisWorkbook
    Application.ScreenUpdating = False
    .Sheets(SheetName).Copy
            
With ActiveWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
With ws.UsedRange
.Value = .Value
End With
        Application.DisplayAlerts = False
       .SaveAs FolderPath & FileName & " " & Format(Now, "dd-mm-yyyy hh-mm-ss") & ".xlsx"  'امتداد الملف
        Application.DisplayAlerts = True
            .Close False
        End With
        Application.ScreenUpdating = True
    End With
    
          MsgBox "Your's Sheet Exported Now ...", 64
    End If
    
End Sub

 

بيان وقتى 2.xlsm