Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 259|回复: 1

[求助] 批量解压需要在这个代码的基础上要怎么改呢?

[复制链接]
发表于 2020-1-8 17:14 | 显示全部楼层 |阅读模式
下面是我没有用解压软件解压文件的VBA代码,但是只能选择并解压一个文件,我想批量解压文件,这种有没有办法,在这个代码的基础上要怎么改呢?

Sub Unzip1_one_file()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
    If Not (Fname = False) Then
        '新文件夹的上级文件夹.
        '你也可以支持指定路径 DefPath = "C:\Users\Ron\test\"
        DefPath = "C:\Users\EJJOLLI\Desktop\file\"
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If
        '创建文件夹名称
        
        FileNameFolder = DefPath & Range("B4")
        '提取所有文件到此创建的文件夹
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
        
    End If
End Sub
发表于 2020-1-9 10:59 | 显示全部楼层
Option Explicit


'选择
Sub Unzip1_one_file()
    Dim x, y
    x = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True)
    If VBA.IsArray(x) Then
        For Each y In x
            Call test2(y)
        Next
    ElseIf x <> False Then
            Call test2(y)
    End If
End Sub


'解压
Sub test2(f)
    Dim oApp As Object
    Dim fld As Variant
    Dim p As String

    '新文件夹的上级文件夹.
    '你也可以支持指定路径 p = "C:\Users\Ron\test\"
    p = "d:\abc"
    If Right(p, 1) <> "\" Then p = p & "\"

    '创建文件夹名称
    fld = p & Range("B4")

    '提取所有文件到此创建的文件夹
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(fld).CopyHere oApp.Namespace(f).items

End Sub




没检查路径是否有效

回复

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-8-14 04:17 , Processed in 0.031201 second(s), 4 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表