View Full Version : [SOLVED] VBA to operate on an external drive + files dispatching in folders
Frederic
08-31-2017, 12:57 AM
Hi,
Below is a code sent by mdmackillop which I had some trouble using.
[Code can't be attached because less then 5 post in VBAX]
Please see below my issues once I enter the code.
[Img can't be uploaded because less then 5 post in VBAX]
I really can't figure out how to make this excel run on it's own on the drive. It will always refer to a USB port (e:\ and making it not functional for other user when they plug in the drive.
How can a VBA look up only for an external drive according to it's name instead of looking for a port entry.
This is the USB drive structure
e:\w\
e:\w\files_depository\
e:\w\zip_depository\
e:\w\patched_depository\
e:\w\data_extractor.xlsm
In this case the drive name was "w" but if confusing we can call it (e:\extractor\) which contains the listed above folder and files for your clarity.
See below the value issue due to the USB drive roots.
[Img can't be uploaded because less then 5 post in VBAX]
Thank you in advance for your time and your help !
Frederic
08-31-2017, 01:00 AM
Hi,
Below is a code sent by mdmackillop which I had some trouble using.
See thread Solved: Drive letters for Devices with Removable Storage
Can you please post the code instead of pictures ?
mdmackillop
08-31-2017, 01:24 AM
Code amended to look for zip folder in Data_Extractor location as default.
Code deleted
Frederic
08-31-2017, 01:26 AM
Can you please post the code instead of pictures ?
I couldn't post the code till reaching my 5th post, but thanks to you I will !
"To be able to post links your post count must be 5 or greater. Your post count is 4 momentarily."
Frederic
08-31-2017, 02:13 AM
Code amended to look for zip folder in Data_Extractor location as default.
Thanks, ActiveWorkbook.Path seems to be the right approach, however there still seems to be an issue, see below the issue regarding the path for external drive name W.
20207
20208
"ActiveWorkbook.Path = "E:"
mdmackillop
08-31-2017, 02:15 AM
Change it to
ChDir ActiveWorkbook.Path
You should post the code, not a link.
Frederic
08-31-2017, 03:00 AM
Change it to
ChDir ActiveWorkbook.Path
Here is the amended code as per your advice:
Option Explicit
Sub Unzip1()
'Modified from https://www.rondebruin.nl/win/s7/win002.htm
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
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 = Split(Dir(DefPath & "tmp" & "\*.csv"), "_")
fld = f(0) & "_" & f(1)
'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
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
ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)
f = Dir
Loop Until f = ""
Application.DisplayAlerts = False
wb.Sheets(1).Delete
wb.Close True
Application.DisplayAlerts = False
End Sub
Thanks ! Made the changes and the code work till it stopped
ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)
With this error below:
20209
Additionally, I noticed that the code created another patched_depository inside the zip_depository, how can I re-root the code to the correct folder. E:\W\patched_depository
See below for reference the drive output.txt
Volume in drive E is W
Volume Serial Number is 2862-C7FC
Directory of E:\
29-Aug-17 04:45 PM <DIR> zip_depository
30-Aug-17 01:52 PM <DIR> files_depository
30-Aug-17 01:55 PM <DIR> patched_depository
30-Aug-17 05:26 PM 523 OpenUrl.bas
31-Aug-17 11:05 AM 27,605 data_extractor.xlsm
31-Aug-17 11:51 AM 25 output.txt
3 File(s) 28,153 bytes
Directory of E:\System Volume Information
29-Aug-17 04:45 PM <DIR> .
29-Aug-17 04:45 PM <DIR> ..
29-Aug-17 04:45 PM 12 WPSettings.dat
29-Aug-17 04:45 PM 76 IndexerVolumeGuid
2 File(s) 88 bytes
Directory of E:\zip_depository
29-Aug-17 04:45 PM <DIR> .
29-Aug-17 04:45 PM <DIR> ..
29-Aug-17 09:12 AM 2,437 CSV_2017_Q2_1672672_791616.zip
31-Aug-17 11:27 AM <DIR> tmp
31-Aug-17 11:27 AM <DIR> patched_depository
1 File(s) 2,437 bytes
Directory of E:\zip_depository\tmp
31-Aug-17 11:27 AM <DIR> .
31-Aug-17 11:27 AM <DIR> ..
28-Jul-17 01:53 AM 129 201706_Clinton_Battery_Utility-_LLC_indexPub.CSV
28-Jul-17 01:53 AM 617 201706_Clinton_Battery_Utility-_LLC_ident.CSV
2 File(s) 746 bytes
Directory of E:\zip_depository\patched_depository
31-Aug-17 11:27 AM <DIR> .
31-Aug-17 11:27 AM <DIR> ..
31-Aug-17 11:27 AM <DIR> 201706_Clinton
0 File(s) 0 bytes
Directory of E:\zip_depository\patched_depository\201706_Clinton
31-Aug-17 11:27 AM <DIR> .
31-Aug-17 11:27 AM <DIR> ..
31-Aug-17 11:27 AM 8,041 201706_Clinton.xlsx
1 File(s) 8,041 bytes
Directory of E:\files_depository
30-Aug-17 01:52 PM <DIR> .
30-Aug-17 01:52 PM <DIR> ..
0 File(s) 0 bytes
Directory of E:\patched_depository
30-Aug-17 01:55 PM <DIR> .
30-Aug-17 01:55 PM <DIR> ..
0 File(s) 0 bytes
Total Files Listed:
9 File(s) 39,465 bytes
20 Dir(s) 30,984,028,160 bytes free
mdmackillop
08-31-2017, 03:20 AM
You advised in your original post a filename strucure of "YYYYMM_NAME_contracts.CSV"
I used this to extract "contracts", in this case, using underscore as the separator
ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)
If your filename is now "201706_Clinton_Battery_Utility-_LLC_indexPub.CSV" you can see the issue
There will also be a problem here
'Create folder based on filename f = Split(Dir(DefPath & "tmp" & "\*.csv"), "_")
fld = f(0) & "_" & f(1)
If you install the free izarc zip software you can use these few lines of code:
Sub M_snb()
With CreateObject("scripting.filesystemobject")
For Each it In .drives
If Dir(it & "\zip_depository\CSV_") <> "" Then
Shell "F:\IZARCcc\izarcc -m " & it & "\zip_depository\" & Dir(it & "\zip_depository\CSV_") & " " & it & "\W\patched_depository"
Exit Sub
End If
Next
End With
End Sub
Frederic
08-31-2017, 08:28 AM
You advised in your original post a filename strucure of "YYYYMM_NAME_contracts.CSV"
I used this to extract "contracts", in this case, using underscore as the separator
ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)
If your filename is now "201706_Clinton_Battery_Utility-_LLC_indexPub.CSV" you can see the issue
There will also be a problem here
'Create folder based on filename f = Split(Dir(DefPath & "tmp" & "\*.csv"), "_")
fld = f(0) & "_" & f(1)
Sorry for not being very being very explicit.
Here is the idea:
What I am basically trying to develop is a UI via an excel that would handle the complete course of data extraction and manages folder in addition of their assignation according to their name.
(As mentioned earlier, the location of the excel of the excel VBA will be on an external drive, that will be used by different users)
Most datas are collected from this website eqrreportviewer.ferc.gov (and if it was possible I would like even to have a VBA command to look up for fillings and download the looked up data off their FTP temporary repository folder. (This would be relatively to hopeful according to my knowledge base)
Later on, I would like to implement another VBA which formats and select all the transactions spreadsheet into a single workbook and run some analysis. (One of the reason of binding them into a single workbook)
Concerning the files, they are usually structured almost the same but with different names according to the entity registered name. (see for your self on the website download section)
In the first step documents are downloaded under a zip with the following format: MTH_DD_YYY_HH_MM_SS_email"at"email.com.zip, and they are usually downloadable for a period of 24h
once the one above is unzipped you get another zip with the following format : CSV_YYYY_QX_DIGITS_DIGITS.zip (Q stands for quarterly and X could be 1 to 4)
and finally the 4 CSV file with similar formats such as below:
YYYYMM_name_name_name-_name_contracts.CSV
YYYYMM_name_name_name-_name_ident.CSV
YYYYMM_name_name_name-_name_indexPub.CSV
YYYYMM_name_name_name-_name_transactions.CSV
Now that you have a general and in depth idea of the outcome, is this feasible or due to many variable with the files name should I give up ?
Thanks for letting me know as I do not want to take to much of your time.
mdmackillop
08-31-2017, 09:44 AM
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
Frederic
09-01-2017, 01:30 AM
Try this version
Awesome ! This one did the trick for CSV_YYYY_QX_DIGITS_DIGITS.zip beside a small folder issue (see below in bold) ! Thanks a lot, I'm reaching closer to my goal !
Do you think its possible to amend the code with an If function if zip fname format is MTH_DD_YYY_HH_MM_SS_email"at"email.com.zip, unzip in temporary folder and then unzip the CSV_YYYY_QX_DIGITS_DIGITS.zip ?
See below in bold:
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 the folder still shows up inside the w:\zip_depository\patched_depository instead of w:\patched_depository
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 (CSV_YYYY_QX_DIGITS_DIGITS.zip)
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
'Can the formula create a temporary folder for zip based on its filename (MTH_DD_YYY_HH_MM_SS_email"at"email.com.zip) and then extract fname CSV_YYYY_QX_DIGITS_DIGITS.zip?
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
End Sub
mdmackillop
09-01-2017, 01:44 AM
Sorry, no time today.
Did you overlook http://www.vbaexpress.com/forum/showthread.php?60574-VBA-to-operate-on-an-external-drive-files-dispatching-in-folders&p=368319&viewfull=1#post368319 ?
Frederic
09-01-2017, 07:41 AM
Sorry, no time today.
Don't worry and thanks for all your precious help that you have provided me so far !
Did you overlook http://www.vbaexpress.com/forum/showthread.php?60574-VBA-to-operate-on-an-external-drive-files-dispatching-in-folders&p=368319&viewfull=1#post368319 ?
Thanks Snb, I did have a look but since the external drive might be used by other user with limited knowledge or no rights to install on their professional computer izarc zip, It would be better to stick with the default explorer unzipper.
mdmackillop
09-01-2017, 08:00 AM
Do you think its possible to amend the code with an If function if zip fname format is MTH_DD_YYY_HH_MM_SS_email"at"email.com.zip, unzip in temporary folder and then unzip the CSV_YYYY_QX_DIGITS_DIGITS.zip ?
Can you post sample zip files? What would the sub-folder, file names and workbook sheets be named?
Frederic
09-02-2017, 12:53 AM
Can you post sample zip files? What would the sub-folder, file names and workbook sheets be named?
ftp://eqrdownload.ferc.gov/DownloadRepositoryProd/Selective/Sep_02_2017_03_52_49_f@fxzy.com.zip
mdmackillop
09-02-2017, 09:09 AM
See attached zip for revised code and sample files. I can't duplicate the sub-folder error you describe.
Frederic
09-28-2017, 03:12 AM
See attached zip for revised code and sample files. I can't duplicate the sub-folder error you describe.
For some reason I thought I answered back to you on this thread.
Your Zip solved it all, but I wouldn't be able to explain why did I get such error.
Thanks again for all of your help, I really appreciate !
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.