Exporting by unique values, and name/folder by cell contents

[dakpluto]

ok, this might be a tough one, and I need some help.






OK, I have a database of about 120,000 elements that I need split up based on the contents of a column (for purposes say the table is named Accounts and the column is called Routes). The column in question is in the following format:


xxx-xxxxxxxx


The x are all integers. I need to export the rows in an excel sheet by the unique values in this column. (There is about 650 unique values.) In addition they need to be saved in the following format:


C:\example\(the three numbers on the left, before the dash)\(the first five numbers after the dash)\(the 8 numbers after the dash).xlsx


I'm sure this is possible in VBA, but I'm not familiar enough with VBA to write it out myself, and I really don't want to have to do 600+ query and 600+ saved exports.


Any help on this would be greatly appreciated.

[Xipooo]

There are a few different ways to go about it, but I'd say you should first make a Group By query that just gets the values from that field so that you only get the unique values.

From there you can open the query as a recordset and then run another query on each value to just get the results from your Accounts and export them to an Excel. You will also have to use the FSO resources to manipulate your file system. You can use the Mid function to parse out each folder you need to create and the filename. You will also need to create a placeholder query that you can do the Excel export from. So just make a query called qryTemp and save it. Doesn't matter what you initially put in it, we'll be changing the SQL in code.

dim db as database
dim rs as recordset
dim FSO as object
dim rootFolder as string
dim subFolder as string
dim fileName as string

set FSO as CreateObject("Scripting.FileSystemObject")
set db = currentdb
set rs = db.openrecordset("SELECT Routes FROM Accounts GROUP BY Routes", dbOpenDynaset, dbSeeChanges)

do while not rs.EOF
  rootFolder = mid(rs!Routes, 0, 3) & "\"
  subFolder = mid(rs!Routes, 5, 5) & "\"
  fileName = mid(rs!Routes, 5, 8)
  if not FSO.FolderExists("c:\Example\" & rootFolder & subFolder) then FSO.CreateFolder("c:\Example\" & rootFolder & subFolder)
  if FSO.FileExists("c:\Example\" & rootFolder & subFolder & fileName) then FSO.DeleteFile("c:\Example\" & rootFolder & subFolder & fileName, True)
  db.QueryDefs("qryTemp").SQL = "SELECT * FROM Accounts WHERE Routes = '" & rs!Routes & "'"
  docmd.OutputTo acOutputQuery, "qryTemp", acFormatXLS, "c:\Example\" & rootFolder & subFolder & fileName, False
  rs.movenext
loop
set db = nothing
set rs = nothing

[Xipooo]

Did this work dakpluto?

[dakpluto]

dim db as database
dim rs as recordset
dim FSO as object
dim rootFolder as string
dim subFolder as string
dim fileName as string

set FSO = CreateObject("Scripting.FileSystemObject")
set db = currentdb
set rs = db.openrecordset("SELECT Routes FROM Accounts GROUP BY Routes", dbOpenDynaset, dbSeeChanges)

do while not rs.EOF
  rootFolder = mid(rs!Routes, 0, 3) & "\"
  subFolder = mid(rs!Routes, 5, 5) & "\"
  fileName = mid(rs!Routes, 5, 8)
  if not FSO.FolderExists("c:\Example\" & rootFolder & subFolder) then FSO.CreateFolder("c:\Example\" & rootFolder & subFolder)
  if FSO.FileExists("c:\Example\" & rootFolder & subFolder & fileName) then FSO.DeleteFile("c:\Example\" & rootFolder & subFolder & fileName, True)
  db.QueryDefs("qryTemp").SQL = "SELECT * FROM Accounts WHERE Routes = '" & rs!Routes & "'"
  docmd.OutputTo acOutputQuery, "qryTemp", acFormatXLS, "c:\Example\" & rootFolder & subFolder & fileName, False
  rs.movenext
loop
set db = nothing
set rs = nothing

Getting a syntax error, expected = on this one:

if FSO.FileExists("c:\Example\" & rootFolder & subFolder & fileName) then FSO.DeleteFile("c:\Example\" & rootFolder & subFolder & fileName, True)

I also corrected:
set FSO as CreateObject("Scripting.FileSystemObject")
to the correct:
set FSO = CreateObject("Scripting.FileSystemObject")

[dakpluto]

OK, fixed the above, I just simply removed the , TRUE and it compiled.

My new issue, I'm getting a RunTime error 76 Path not found on the CreateFolder method.

[dakpluto]

Worked out the issues! Problem is CreateFolder method needs to run and do checks for every folder level, so I just created the rootFolders manually since there wasn't that many to do. Works like a charm now.

my working code:

Public Function manySheets()
    Dim db As Database
    Dim rs As Recordset
    Dim FSO As Object
    Dim rootFolder As String
    Dim subFolder As String
    Dim fileName As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT Routes FROM Accounts GROUP BY Routes", dbOpenDynaset, dbSeeChanges)
    
    Do While Not rs.EOF
      rootFolder = Mid(rs!Routes, 1, 3)
      subFolder = Mid(rs!Routes, 5, 5)
      fileName = Mid(rs!Routes, 5, 8)
      If Not FSO.FolderExists("C:\Example\" & rootFolder & "\" & subFolder) Then
        FSO.CreateFolder ("C:\Example\" & rootFolder & "\" & subFolder)
    End If
      If FSO.FileExists("C:\Example\" & rootFolder & "\" & subFolder & "\" & fileName) Then
        FSO.DeleteFile ("C:\Example\" & rootFolder & "\" & subFolder & "\" & fileName)
    End If
      db.QueryDefs("qryTemp").SQL = "SELECT * FROM Accounts WHERE Routes = '" & rs!Routes & "'"
      DoCmd.OutputTo acOutputQuery, "qryTemp", acFormatXLS, "C:\Example\" & rootFolder & "\" & subFolder & "\" & fileName & ".xls", False
      rs.MoveNext
    Loop
    Set db = Nothing
    Set rs = Nothing


End Function

[Xipooo]

Glad to hear it worked out for you.

Sorry about the untested code. It happens when we don't have a genuine development environment to code out of. We have to do it from memory and mine is pretty labored as it is.

[dakpluto]

Glad to hear it worked out for you.

Sorry about the untested code. It happens when we don't have a genuine development environment to code out of. We have to do it from memory and mine is pretty labored as it is.

Haha, no problem. the little untested things never bother me. Hell, I learn more from those kinds of things than anything else sometimes.