PIECE OF CAKE - MS Excel - Zipando - Compactando a Planilha Atual - Zip the ActiveWorkbook

Este script faz uma cópia do Activeworkbook e o compacta em "C: \ Bernardes \" com um carimbo de data e hora. Altere esta pasta ou use seu caminho padrão Application.DefaultFilePath

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

    DefPath = "C:\Bernardes\"    '<< 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:03"))
        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

#A&A #PIECEOFCAKE #POC #VBA #RondeBruin #MS #Excel

Veja também:

• MS Excel - Zipando - Abra uma Janela e Escolha os Arquivos que deseja Compacatar
• MS Excel - Zipando - Escolha uma Pasta e Compacte Tudo Nela
• MS Excel - Zipando - Compacte Todos os Arquivos Contidos na Pasta Informada no Código
• MS Excel - Zipando - Compactando a Planilha Atual
• MS Excel - Zipando - Compactando e Enviando por e-Mail

Consulte-nos

⬛◼◾▪ Social Media ▪◾◼⬛

• FACEBOOK • TWITTER • INSTAGRAM • TUMBLR • GOOGLE+ • LINKEDIN • PINTEREST

⬛◼◾▪ Blogs ▪◾◼⬛ 

• VBA Specialist® • VBA Excel Specialist®

• VBA Access Specialist® • VBA Dashboards Specialist®

• VBA Infografics Specialist® • VBA Pharma Specialist® 

⬛◼◾▪ CONTATO ▪◾◼⬛

brazilsalesforceeffectiveness@gmail.com