Excel–VBA压缩多文件及文件夹(excel880.com)

前阵子做个项目要频繁压缩文件，到处找压缩文件的代码总没找到合适的，只好自己动手了 
本过程实现调用系统安装的winrar软件完成压缩多文件及文件夹功能 
其实际效果等同与在文件夹里选择多个文件及文件夹后右键压缩功能
本代码最大的好处是压缩文件夹时不会带根目录  非常适用于文件及文件夹混合压缩
可指定压缩后目录
得到帮助你请动动手指  打开 Excel880淘宝店 给我的小店加个收藏 
若想看到更多  请移步本人作品集合 总能找到你有用的 Excel880作品集

代码如下

'****VBA压缩文件********Copyright@2015 www.excle880.com**************************************
'*将filelist文件或文件夹列表压缩到rarname文件中 注意都是用绝对路径 filelist之间逗号分隔
'*eg. E8_RarFiles "D:\Documents\Desktop\2.rar", "D:\Documents\Desktop\2\2,D:\Documents\Desktop\2\1.txt"
'****作者：百度不到去谷歌 QQ80871835  *******************************************************
Sub E8_RarFiles(rarname, filelist)
    Dim Source As String '压缩前的原始文件
    Dim Target As String '压缩后的目标文件
    Dim cmdstr As String 'Shell指令中的字符串
    Dim Rarexe As String 'WINRAR执行文件的位置
    Dim arr, dic, i, n, k, iitem, ks
    Rarexe = "C:\program files\winrar\winrar"
    arr = Split(filelist, ",")
    Set dic = CreateObject("scripting.dictionary")
    For i = 0 To UBound(arr)
        n = InStrRev(arr(i), "\")
        k = Left(arr(i), n - 1)
        iitem = """" & Mid(arr(i), n + 1) & """"
        dic(k) = dic(k) & " " & iitem
    Next
    ks = dic.keys
    rarname = """" & rarname & """" '空格路径 加双引号
    For i = 0 To dic.Count - 1
        ChDrive ks(i)
        ChDir ks(i)
        Source = dic(ks(i))
        cmdstr = Rarexe & " a " & rarname & " " & Source
        Shell cmdstr, vbHide
    Next
End Sub
Private Sub Test()
    Dim i&, j&, k&, arr, brr, s
    s = ThisWorkbook.Path & "\"
    E8_RarFiles s & "test.rar", s & "1.txt," & s & "2.txt," & s & "1 2 3"
End Sub

附件下载（密码：WTE6）