Excel VBA 提取 zip 文件并使用单元格值重命名内容

Question

我有：

列中 .zip 文件的文件名
.zip 文件夹中的文件（文件夹路径存储在单元格中）
.zip 文件都有不同的名称（由列中的列表给出）
.zip 文件都有 "same" 内容 (null.shp, null.dbf, null.shx, ..)

一个有效的 "snippedtogether"-代码（但是是静态的，所以它只适用于一个特定的文件）：

Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String


Fname = Tabelle1.Range("A7").Value & "testzip.zip" 'Folder Path and Filename of ONE file. Needs to be changed for loop

If Fname = False Then
    'Do nothing
Else
    'Destination folder
    DefPath = Tabelle1.Range("A7").Value 'Folder Path
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    FileNameFolder = DefPath

    'Extract the files into the Destination folder
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items

'Rename the files (newfilename was for a testloop)
strFile = Dir(DefPath & "*.shp")
Name DefPath & strFile As DefPath & newfilename & ".shp"

'Rename the files (null.cpg will be renamed into test.cpg)
strFile = Dir(DefPath & "*.cpg")
Name DefPath & strFile As DefPath & "test.cpg"

strFile = Dir(DefPath & "*.dbf")
Name DefPath & strFile As DefPath & "test.dbf"

strFile = Dir(DefPath & "*.kml")
Name DefPath & strFile As DefPath & "test.kml"

strFile = Dir(DefPath & "*.prj")
Name DefPath & strFile As DefPath & "test.prj"

strFile = Dir(DefPath & "*.shx")
Name DefPath & strFile As DefPath & "test.shx"


    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

我需要的：

编辑： Excel 中的 L 列包含 .zip 文件名：abc.zip、def.zip、ghi.zip、jkl.zip、mno.zip。文件夹 C:/Temp/ 包含：abc.zip、def.zip、ghi.zip、jkl.zip、mno.zip。这些文件需要解压缩。所有这些 zip 文件的内容都命名为：null.shp、null.dbf、null.shx、null.cpg、null.kml、null.prf。因此内容需要重命名，以匹配它们的 .zip-filename/cellvalue。 --> abc.shp, abc.shx, abc.kml, ... --> def.shp, def.shx, def.kml, ...最有可能解压缩后立即被下一个 .zip 文件覆盖^^ -编辑结束

考虑一个遍历存储 .zip 文件名的列并返回其值的循环。使用这些值重命名刚刚解压缩的文件。

正在使用 For 循环；例如部分工作的：

Sub UnzipAndRename()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String

Dim rCell As Range
Dim rRng As Range


Set rRng = Range("L3:L5")

For Each rCell In rRng.Cells

newfilename = rCell.Value
Fname = Tabelle1.Range("A7").Value & rCell.Value

Next rCell

If Fname = False Then
    'Do nothing
Else
    'Destination folder
    DefPath = Tabelle1.Range("A7").Value
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    FileNameFolder = DefPath

    '        'Delete all the files in the folder DefPath first if you want
    '        On Error Resume Next
    '        Kill DefPath & "*.*"
    '        On Error GoTo 0

    'Extract the files into the Destination folder
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items

    'MsgBox "You find the files here: " & FileNameFolder



'Rename the extracted files:

' Get first and only file
strFile = Dir(DefPath & "*.shp")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".shp"

' Get first and only file
strFile = Dir(DefPath & "*.cpg")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".cpg"

' Get first and only file
strFile = Dir(DefPath & "*.dbf")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".dbf"

' Get first and only file
strFile = Dir(DefPath & "*.kml")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".kml"

' Get first and only file
strFile = Dir(DefPath & "*.prj")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".prj"

' Get first and only file
strFile = Dir(DefPath & "*.shx")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".shx"



    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

它部分工作。但它只处理一个文件而忽略其他文件。在另一次尝试（没有错误消息）时，它只是将所有文件复制到同一个文件夹中。错误在哪里，这是一个好的解决方案还是有更好的方法来做到这一点？

Answer 1

这是从这里获取的：并进行了转换。

Sub GetData()
Dim iRow As Integer 'row counter
Dim iCol As Integer 'column counter
Dim savePath As String 'place to save the extracted files

iRow = 1 'start at first row
iCol = 1 'start at frist column
'set the save path to the temp folder
savePath = Environ("TEMP")


Do While ActiveSheet.Cells(iRow, iCol).Value <> ""
    UnzipFile savePath, ActiveSheet.Cells(iRow, iCol).Value
    iRow = iRow + 1
Loop



End Sub



Sub UnzipFile(savePath As String, zipName As String)
Dim oApp As Shell
Dim strZipFile As String
Dim strFile As String
'get a shell object
Set oApp = CreateObject("Shell.Application")
    'check to see if the zip contains items
    If oApp.Namespace(zipName).Items.Count > 0 Then
        Dim i As Integer
        'loop through all the items in the zip file
        For i = 0 To oApp.Namespace(zipName).Items.Count - 1
            'save the files to the new location
            oApp.Namespace(savePath).CopyHere oApp.Namespace(zipName).Items.Item(i)
            Dim extensionTxt As String

            'get the Zip file name
            strZipFile = oApp.Namespace(zipName).Items.Item(i).Parent
            'get the unzipped file name
            strFile = oApp.Namespace(zipName).Items.Item(i)
            'assumes all extensions are 3 chars long
            extensionTxt = Right(strFile, 4)
            Name savePath & "\" & strFile As savePath & "\" & Replace(strZipFile, ".zip", extensionTxt)
        Next i
    End If
'free memory
Set oApp = Nothing

End Sub

Excel VBA 提取 zip 文件并使用单元格值重命名内容

Excel VBA extract zip files and rename content with cell values

excel

vba

rename

unzip