Try this version
Option Explicit
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim Pth As String
Dim f As Variant, f1, f2, Dt, Nm
Dim fld As String
Dim TgtNameFolder As String
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
Application.ScreenUpdating = False
Pth = Left(Fname, InStr(4, Fname, "\"))
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
DefPath = Pth
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
FileNameFolder = DefPath & "tmp" & "\"
'Make the normal folder in DefPath
On Error Resume Next
MkDir FileNameFolder
On Error GoTo 0
'Create the targetfolder name
TgtNameFolder = DefPath & "patched_depository" & "\"
'Make the normal folder in DefPath
On Error Resume Next
MkDir TgtNameFolder
On Error GoTo 0
'Extract the files into the newly created tmp folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'Create folder based on filename
f = Dir(DefPath & "tmp" & "\*.csv")
f1 = InStr(1, f, "_") + 1
f2 = InStrRev(f, "_")
Dt = Mid(f, 1, f1 - 2)
Nm = Mid(f, f1, f2 - f1)
fld = Dt & "_" & Nm
'Make the target folder in DefPath
On Error Resume Next
MkDir TgtNameFolder & fld
On Error GoTo 0
Call DoStuff(fld, DefPath & "tmp", TgtNameFolder & fld)
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Left(FileNameFolder, Len(FileNameFolder) - 1), True
End If
Application.ScreenUpdating = True
Shell "Explorer.exe " & TgtNameFolder, vbNormalFocus
End Sub
Sub DoStuff(fld, tmp, Pth)
Dim wb As Workbook, csv As Workbook, f
Dim f1, f2, sht
Set wb = Workbooks.Add
wb.SaveAs Filename:=Pth & "\" & fld & ".xlsx", FileFormat:=xlOpenXMLWorkbook
f = Dir(tmp & "\*.csv")
Do
Set csv = Workbooks.Open(Filename:=tmp & "\" & f)
csv.Sheets(1).Copy after:=wb.Sheets(wb.Sheets.Count)
csv.Close False
Kill tmp & "\" & f 'CSV
'Sheet name
f1 = InStrRev(f, "_") + 1
f2 = InStrRev(f, ".")
sht = Mid(f, f1, f2 - f1)
ActiveSheet.Name = sht
f = Dir
Loop Until f = ""
Application.DisplayAlerts = False
wb.Sheets(1).Delete
wb.Close True
Application.DisplayAlerts = False
End Sub
Reply With Quote
Originally Posted by Frederic
