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

Question

我有什么：

• 一列中 .zip 文件的文件名
• .zip 文件夹中的文件（文件夹路径存储在单元格中）
• .zip 文件都有不同的名称（由列中的列表给出）
• .zip 文件都有“相同”的内容（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 文件名/单元格值。 --> 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

这是从这里获取的：Excel VBA - read .txt from .zip files 并已转换。

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