Hi
I am trying to create an excel file from a bunch of CSV files that are saved, in an zip folder.
So I have a Zip folder that has 7 CSV files, I am trying to create an excel spreadhseet for them to be input in to different tabs. I managed to do that but it is getting saved in of of my folders, I need it to just to have the excel, but not get it saved, but just open the file in a new window.
This is the code I have
Option Explicit
Sub UnzipAndMerge()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String, StrFile As String
Dim I As Long, Wb As Workbook, FinalWb As Workbook
Dim num As Long, Sht As Worksheet, ShtName As String
ChDir (ThisWorkbook.Path)
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True)
If IsArray(Fname) Then
'Root folder for the new folder.
DefPath = ThisWorkbook.Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
For I = LBound(Fname) To UBound(Fname)
num = oApp.Namespace(FileNameFolder).items.Count
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items
Set FinalWb = Workbooks.Add
StrFile = Dir(FileNameFolder)
Do While Len(StrFile) > 0
Set Wb = Workbooks.Open(FileNameFolder & StrFile)
Wb.Sheets(1).Copy FinalWb.Sheets(1)
Wb.Close False
Set Wb = Nothing
StrFile = Dir
Loop
'On Error Resume Next
DeleteFolder (FileNameFolder)
For Each Sht In FinalWb.Sheets
Select Case Right(Sht.Name, 3)
Case "MON"
Sht.Name = "MONDAY"
Sht.Move FinalWb.Sheets(2)
Case "TUE"
Sht.Name = "TUESDAY"
Sht.Move FinalWb.Sheets(3)
Case "WED"
Sht.Name = "WEDNESDAY"
Sht.Move FinalWb.Sheets(4)
Case "THU"
Sht.Name = "THURSDAY"
Sht.Move FinalWb.Sheets(5)
Case "FRI"
Sht.Name = "FRIDAY"
Sht.Move FinalWb.Sheets(6)
Case "SAT"
Sht.Name = "SATURDAY"
Sht.Move FinalWb.Sheets(7)
Case "SUN"
Sht.Name = "SUNDAY"
Sht.Move FinalWb.Sheets(1)
Case "et1", "et2", "et3"
Sht.Delete
End Select
Next Sht
FinalWb.SaveAs ThisWorkbook.Path & "\Next weeks logs" & 1
On Error GoTo 0
FinalWb.Close
Set FinalWb = Nothing
Next I
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
On Error GoTo 0
End If
End Sub
Sub DeleteFolder(MyPath As String)
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
FSO.DeleteFolder MyPath
End Sub
Please advice
I am trying to create an excel file from a bunch of CSV files that are saved, in an zip folder.
So I have a Zip folder that has 7 CSV files, I am trying to create an excel spreadhseet for them to be input in to different tabs. I managed to do that but it is getting saved in of of my folders, I need it to just to have the excel, but not get it saved, but just open the file in a new window.
This is the code I have
Option Explicit
Sub UnzipAndMerge()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String, StrFile As String
Dim I As Long, Wb As Workbook, FinalWb As Workbook
Dim num As Long, Sht As Worksheet, ShtName As String
ChDir (ThisWorkbook.Path)
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True)
If IsArray(Fname) Then
'Root folder for the new folder.
DefPath = ThisWorkbook.Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
For I = LBound(Fname) To UBound(Fname)
num = oApp.Namespace(FileNameFolder).items.Count
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items
Set FinalWb = Workbooks.Add
StrFile = Dir(FileNameFolder)
Do While Len(StrFile) > 0
Set Wb = Workbooks.Open(FileNameFolder & StrFile)
Wb.Sheets(1).Copy FinalWb.Sheets(1)
Wb.Close False
Set Wb = Nothing
StrFile = Dir
Loop
'On Error Resume Next
DeleteFolder (FileNameFolder)
For Each Sht In FinalWb.Sheets
Select Case Right(Sht.Name, 3)
Case "MON"
Sht.Name = "MONDAY"
Sht.Move FinalWb.Sheets(2)
Case "TUE"
Sht.Name = "TUESDAY"
Sht.Move FinalWb.Sheets(3)
Case "WED"
Sht.Name = "WEDNESDAY"
Sht.Move FinalWb.Sheets(4)
Case "THU"
Sht.Name = "THURSDAY"
Sht.Move FinalWb.Sheets(5)
Case "FRI"
Sht.Name = "FRIDAY"
Sht.Move FinalWb.Sheets(6)
Case "SAT"
Sht.Name = "SATURDAY"
Sht.Move FinalWb.Sheets(7)
Case "SUN"
Sht.Name = "SUNDAY"
Sht.Move FinalWb.Sheets(1)
Case "et1", "et2", "et3"
Sht.Delete
End Select
Next Sht
FinalWb.SaveAs ThisWorkbook.Path & "\Next weeks logs" & 1
On Error GoTo 0
FinalWb.Close
Set FinalWb = Nothing
Next I
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
On Error GoTo 0
End If
End Sub
Sub DeleteFolder(MyPath As String)
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
FSO.DeleteFolder MyPath
End Sub
Please advice