VBA to operate on an external drive + files dispatching in folders

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 !

Quote:

---

Originally Posted by Frederic

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 ?

Code amended to look for zip folder in Data_Extractor location as default.

Code:

---

Code deleted

---

Quote:

---

Originally Posted by snb

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."

Quote:

---

Originally Posted by mdmackillop

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.

Attachment 20207
Attachment 20208
"ActiveWorkbook.Path = "E:"

Change it to

Code:

---

ChDir ActiveWorkbook.Path

---

You should post the code, not a link.

Quote:

---

Originally Posted by mdmackillop

Change it to

Code:

---

ChDir ActiveWorkbook.Path

---

---

Here is the amended code as per your advice:

Code:

---

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

Code:

---

  ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)

---

With this error below:

Attachment 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

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

Code:

---

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

Code:

---

        '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:

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

---

Quote:

---

Originally Posted by mdmackillop

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

Code:

---

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

Code:

---

        '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.

Try this version

Code:

---

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

---

Quote:

---

Originally Posted by mdmackillop

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:

Code:

---

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

---

Sorry, no time today.

Did you overlook http://www.vbaexpress.com/forum/show...l=1#post368319 ?

Quote:

---

Originally Posted by mdmackillop

Sorry, no time today.

---

Don't worry and thanks for all your precious help that you have provided me so far !

Quote:

---

Originally Posted by snb

Did you overlook http://www.vbaexpress.com/forum/show...l=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.

Quote:

---

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?

Quote:

---

Originally Posted by mdmackillop

Can you post sample zip files? What would the sub-folder, file names and workbook sheets be named?

---

ftp://eqrdownload.ferc.gov/DownloadR...f@fxzy.com.zip

See attached zip for revised code and sample files. I can't duplicate the sub-folder error you describe.

Quote:

---

Originally Posted by mdmackillop

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 !