Excel VBA extract zip files and rename content with cell values - excel

Question

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?

Answer 1

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