PDA

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

snb
08-31-2017, 01:16 AM
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

snb
08-31-2017, 02:25 AM
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)

snb
08-31-2017, 03:38 AM
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.

snb
09-01-2017, 02:03 AM
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 !