زیپ کردن فایل اکسل

[Haji hadi]

سلام
چطور می توان فایل اکسل به صورت فایل فشرده(zip,rar)ذخیره شود
باتشکر

[علی فاطمی]

با سلام
اگر درست متوجه شده باشم ، با استفاده از نرم افزار winrar به راحتی امکان پذیره . پس از نصب نرم افزار کافیه روی فایلتون راست کلیک کنین بعد گزینه Add to archive بزنید و فایلتون زیپ میشه.

[mokaram]

جناب فاطمی من فکر کنم منظور دوستمون این بود که با کد نویسی تو وی بی این کار را بکنیم چون سوالشونم تو این تالار پرسیدن در هر صورت سواد ما به این موضوع نمیرسه اگه راهی داره دوستان بفرمایند

[امين اسماعيلي]

بادرود

کد های زیر یه فایل اکسل باز یا همون اکتیو رو براتون یه فایل زیپ شده به تاریخ و زمان و نام همون فایل تهیه میکنه قبل از اجرا کد فوق ادرس مربوط به دخیره فایل رو تغییر بدین مثلا اینجا من گفتم تو دسکتاپ ذخیره کنه

C:\Users\amin\Desktop\

کد های فوق رو در یک ماژول که در در واقع Alt+F11 بعد Insert و سپس Insert/module هستش کپی و خارج بشین و از طریق ماکرو کد فوق رو اجرا یا همون Run کنید

Sub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String

    DefPath = "C:\Users\amin\Desktop\"    '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and Zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
    
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
    
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameXls

        MsgBox "Your Backup is saved here: " & FileNameZip

    Else
        MsgBox "FileNameZip or/and FileNameXls exist"

    End If
End Sub

Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub