Boa tarde!!

use a pesquisa para te ajudar.
viewtopic.php?f=10&t=2542
http://planilhando.com.br/forum/viewtop ... =10&t=6589

Modelo não testado!!

Sub Tente()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, i As Integer
    Dim FName, vArr, FileNameZip
    Dim Wkbk
    Dim x As Integer, y As Integer
     
    DefPath = Range("C3") & ""
     

     ' FileNameZip = DefPath & "MyFilesZip " & ".zip"
 
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
       
    Else
         
        
        Set oApp = CreateObject("Shell.Application")
        i = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "")
            sFName = vArr(UBound(vArr))
            x = InStr(sFName, ".")
            y = Len(sFName)
            Wkbk = Left(sFName, y - (y - x) - 1)
            FileNameZip = DefPath & Wkbk & ".zip"
            NewZip (FileNameZip)
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                "Please close it and try again: " & FName(iCtr)
            Else
               
                i = i + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
                 
                
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).Items.Count = i
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr
         
         
        MsgBox "You find the zipfile here: " & FileNameZip
    End If
End Sub

Att

Boa tarde!!

Leia também:
http://www.rondebruin.nl/win/s7/win003.htm

Att

bom dia,... usei a macro mais deu erro em função não definida "split"

mais a q serviria bem pra mim seria essa q postaram, no caso eu queria apenas compactar a planilha ativa ou alguma especifia. usei essa mais da erro arquivo não encotrado

Sub UnZipando()

'ChDir ThisWorkbook.Path 'Altera o diretorio de "trabalho" para o o arquivo
'Sintaxe para winRar

ChDir ActiveWorkbook.FullName ' no caso aqui seria a planilha ativa

arqcomp = ActiveWorkbook.FullName & "Pasta1.xlsm" 'Aqui nome do arquivo, deve ser sem espaços

Shell "C:Arquivos de programasWinRARWinRAR.exe e " & arqcomp, vbMinimizedFocus
End Sub

Creio que compactar o arquivo "corrente", por esse estar aberto, será impedido pelo sistema operacional (gerará erro)

Mas experimente

Sub Zipando()
Dim ArqNome As String, ArqCom As String

'Sintaxe WinRar

ChDir ThisWorkbook.Path    'Altera o diretorio de "trabalho" para o o arquivo

ArqNome = "ip.rar" 'Nome que o arquivo terá
ArqComp = "Boi1.xls" 'Nome do Arquivo a ser compactado

Shell "C:Arquivos de programasWinRARwinRAR a  " & ArqNome & " " & ArqComp
End Sub