Excel VBA extract zip files and rename content with cell values

What i have:

File Names of .zip files in a column
.zip files in a folder (folder path is stored in a cell)
.zip files all have different names (given by the list in a column)
.zip files all have the "same" content (null.shp, null.dbf, null.shx, ..)

A working "snippedtogether"-code (but static so it only works with one specific file):

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

What I need:

edit: Column L in Excel contains the .zip filenames: abc.zip, def.zip, ghi.zip, jkl.zip, mno.zip. Folder C:/Temp/ contains: abc.zip, def.zip, ghi.zip, jkl.zip, mno.zip. The files need to be unziped. And all these zip files have content named all the same: null.shp, null.dbf, null.shx, null.cpg, null.kml, null.prf. So the content needs to be renamed so they match their .zip-filename/cellvalue. --> abc.shp, abc.shx, abc.kml, ... --> def.shp, def.shx, def.kml, ... most likely immediately after unzipped before they get overwritten by next .zip file^^ -edit end

Thought about a loop that runs through the column where .zip filenames are stored and throw back its values. Using the values to rename the just unzipped file(s).

Was messing around with For-loops; For example a partially working one:

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

Its partially working. But it does the job for only one file and ignores the others. On another attempt (with no error message) it just copied all files into the same folder. Wheres the mistake and is this a good solution or are there better ways to do this?

Solution

This was taken from here: Excel VBA - read .txt from .zip files and converted.

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