Read query results into array, export to Excel based on results 2

[ehicks727]

After searching for the answer for three days, I'm finally posting as a question. Any help is greatly appreciated.

I have a table with names and addresses. One of the fields is STATE (however, it's not always called STATE, different tables may have a different name for state). I want to read all the distinct states from the table into a string array. Then I want to parse the entire table into separate Excel spreadsheets with only the data for that state... something like AddressesAK.xls, AddressesAL.xls, etc. If there is a better way of doing it, I'm all ears.

I wanted to keep this all in code because I'll be reusing the code in many other tables (I can change the output file name, etc. as needed). My searches have come up with references to Database and Recordset objects, but I am simply not familiar enough with these, so I wanted to ask for a bit of help. Even if someone could get me pointed in the right direction, that would be great.

Again, help is greatly appreciated. Thanks.

 

[CautionMP]

Something like this?

[navy]Sub [/navy] OutputAddressWorkbooks()
[navy]Dim[/navy] wksOutput [navy]As Object[/navy]
[navy]Dim[/navy] rstStates [navy]As New[/navy] ADODB.Recordset
[navy]Dim[/navy] rstOutput [navy]As New[/navy] ADODB.Recordset
[navy]Dim[/navy] lngRow [navy]As Long[/navy], lngField [navy]As Long[/navy]
[navy]Dim[/navy] sqlStates [navy]As String[/navy], sqlOutput [navy]As String[/navy]

[green]'Define the SQL Strings For the two recordset[/green]
[green]'*** NOTE upDate StateFiledName and TableWithNamesAndAddresses To[/green]
[green]'*** your actual field and table name[/green]
sqlStates = "SELECT DISTINCT [i]StateFiledName[/i] FROM [i]TableWithNamesAndAddresses[/i];"
[green]'The Single quote in the WHERE clause is not a mistake, it will be closed below[/green]
sqlOutput = "SELECT * FROM [i]TableWithNamesAndAddresses[/i] WHERE [i]StateFiledName[/i]='"

[green]'Open the state (driving) recordset[/green]
rstStates.Open sqlStates, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

[navy]Do[/navy]
  [green]'Now open the details For the current state[/green]
  rstOutput.Open sqlOutput & rstStates.Fields(0) & "';", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  [green]'Create the workbook[/green]
  [navy]Set[/navy] wksOutput = CreateObject("Excel.Sheet")
  [green]'Write a header row[/green]
  lngRow = 1
  [navy]For[/navy] lngField = 0 [navy]To[/navy] rstOutput.Fields.Count - 1
      wksOutput.Worksheets(1).Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField).Name
  [navy]Next[/navy] lngField
  [green]'Write the data rows[/green]
  [navy]Do[/navy]
    lngRow = lngRow + 1
    [navy]For[/navy] lngField = 0 [navy]To[/navy] rstOutput.Fields.Count - 1
      wksOutput.Worksheets(1).Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField)
    [navy]Next[/navy] lngField
    rstOutput.MoveNext
  [navy]Loop Until[/navy] rstOutput.EOF
  [green]'Resize the columns, save the workbook, and close[/green]
  [navy]With[/navy] wksOutput
    [navy]For[/navy] lngField = 0 [navy]To[/navy] rstOutput.Fields.Count - 1
      .Worksheets(1).Columns(lngField + 1).AutoFit
    [navy]Next[/navy] lngField
    [green]'*** NOTE: I used the root of C For this example[/green]
    .SaveAs "C:\Addresses" & rstStates.Fields(0)
    .Close
  [navy]End With[/navy]
  [green]'Close the detail recordset[/green]
  rstOutput.Close
  [green]'Move To the Next state[/green]
  rstStates.MoveNext
[navy]Loop[/navy] Until rstStates.EOF

CleanUp:
rstStates.Close
[navy]Set[/navy] rstOutput = [navy]Nothing[/navy]
[navy]Set[/navy] rstStates = [navy]Nothing[/navy]
[navy]Set[/navy] wksOutput = [navy]Nothing[/navy]
[navy]End Sub [/navy]

CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[ehicks727]

Hey CMP, that's really great... I'm trying to get it working.. I made the table, outfile name, and state field name a variable and modified the sql statements accordingly.

However, I'm getting an error on the following line (so far)

Dim rstStates As New ADODB.Recordset

After looking through tektips, I saw a few references to going to tools/references and checking some stuff... I checked the MS Excel 11.0 object library and then the MS ADO ext 2.8 for DDL and Security, but they didn't do the trick. I'm not to sure what I'm doing with this tools/references stuff... this is unchartered territory for me.

the specific error is:

Compile Error: User defined type not defined.

any ideas? thanks.

 

[ehicks727]

Ah, I think I figured it out... I had to check the ActiveX Data Object 2.8 Library.

Thank you again for being so detailed in your reply... it worked like a charm.

 

[CautionMP]

I'm using the Microsoft ActiveX Data Objects 2.1 Library (mdado21.tlb) although 2.5 or 2.8 should work. The code can be changed over to use the Microsoft DAO 3.6 Object Library (dao360.dll) which is optimized for the JET database engine and is included in most Access databases by default. This route won't require the reference to the ADO library, but it's been so long since I used DAO I'm don't remember (read 'no longer qualified') to show you waht changes to make.

I would remove Microsoft ADO Ext. 2.8 for DLL and Security (I have no idea what that Library is for).

The way the routine was written does NOT require a reference to the MS Excel x.x Object Library, I wrote it a tested it without a reference to the library.

Hope this helps,
CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[CautionMP]

Great,
Glad I could help.

CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[ehicks727]

hmm... I tested this on production data and it crashed. I'm working with tables that have up to 1 million records btw... I probably should have mentioned that, sorry.

Anyway, the error I'm getting is...

Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its client


When I debug it, it occurs on this line

wksOutput.Worksheets(1).Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField).Name

any ideas?? thanks, and sorry this is dragging out.

 

[ehicks727]

Here's my modified code... maybe I changed something that affected something.

Sub OutputAddressWorkbooks()

' replace with table name, output file name, and field with states
Dim tbl As String, outputFile As String, stateField As String
tbl = "tblAddr"
outputFile = "c:\data\addr"
stateField = "state"


Dim wksOutput As Object
Dim rstStates As New ADODB.Recordset
Dim rstOutput As New ADODB.Recordset
Dim lngRow As Long, lngField As Long
Dim sqlStates As String, sqlOutput As String

'Define the SQL Strings For the two recordset
'*** NOTE upDate StateFiledName and TableWithNamesAndAddresses To
'*** your actual field and table name
sqlStates = "SELECT DISTINCT " & stateField & " FROM " & tbl & ";"
'The Single quote in the WHERE clause is not a mistake, it will be closed below
sqlOutput = "SELECT * FROM " & tbl & " WHERE " & stateField & "='"

'Open the state (driving) recordset
rstStates.Open sqlStates, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

Do
  'Now open the details For the current state
  rstOutput.Open sqlOutput & rstStates.Fields(0) & "';", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  'Create the workbook
  Set wksOutput = CreateObject("Excel.Sheet")
  'Write a header row
  lngRow = 1
  For lngField = 0 To rstOutput.Fields.Count - 1
      wksOutput.Worksheets(1).Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField).Name
  Next lngField
  'Write the data rows
  Do
    lngRow = lngRow + 1
    For lngField = 0 To rstOutput.Fields.Count - 1
      wksOutput.Worksheets(1).Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField)
    Next lngField
    rstOutput.MoveNext
  Loop Until rstOutput.EOF
  'Resize the columns, save the workbook, and close
  With wksOutput
    For lngField = 0 To rstOutput.Fields.Count - 1
      .Worksheets(1).Columns(lngField + 1).AutoFit
    Next lngField
    '*** NOTE: I used the root of C For this example
    .SaveAs outputFile & rstStates.Fields(0)
    .Close
  End With
  'Close the detail recordset
  rstOutput.Close
  'Move To the Next state
  rstStates.MoveNext
Loop Until rstStates.EOF

CleanUp:
rstStates.Close
Set rstOutput = Nothing
Set rstStates = Nothing
Set wksOutput = Nothing
End Sub

 

[ehicks727]

Would this have anything to do with it???

http://www.tek-tips.com/viewthread.cfm?qid=851363

This post refers to where in/after the loop it closes the (word) document. Actually, this example uses Object.Quit, not .Close

This post does describe the same thing that's happening with my data. It runs through the first state, AK, and then dies with the error msg.

 

[JerryKlmns]

I think that should be

Dim objExcel as Object
Dim objWrkBook as Object
Dim wksOutput as Object
Dim rstStates As New ADODB.Recordset
Dim rstOutput As New ADODB.Recordset
Dim lngRow As Long, lngField As Long
Dim sqlStates As String, sqlOutput As String

tbl = "tblAddr"
outputFile = "c:\data\addr"
stateField = "state"

'Define the SQL Strings For the two recordset
'*** NOTE upDate StateFiledName and TableWithNamesAndAddresses To
'*** your actual field and table name
sqlStates = "SELECT DISTINCT " & stateField & " FROM " & tbl & ";"
'The Single quote in the WHERE clause is not a mistake, it will be closed below
sqlOutput = "SELECT * FROM " & tbl & " WHERE " & stateField & "='"

'Open the state (driving) recordset
rstStates.Open sqlStates, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

Set objExcel = CreateObject("Excel.Application")
Do
  'Now open the details For the current state
  rstOutput.Open sqlOutput & rstStates.Fields(0) & "';", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  'Create the workbook

Set objWrkBook = objExcel.Workbooks.Add
Set wksOutput = objWrkBook.Worksheets(1)
  'Write a header row
  lngRow = 1
  For lngField = 0 To rstOutput.Fields.Count - 1
      wksOutput.Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField).Name
  Next lngField
  'Write the data rows
  Do
    lngRow = lngRow + 1
    For lngField = 0 To rstOutput.Fields.Count - 1
      wksOutput.Cells(lngRow, lngField + 1).Value = rstOutput.Fields(lngField)
    Next lngField
    rstOutput.MoveNext
  Loop Until rstOutput.EOF
  'Resize the columns, save the workbook, and close
  With wksOutput
    For lngField = 0 To rstOutput.Fields.Count - 1
      .Columns(lngField + 1).AutoFit
    Next lngField
  End With
    '*** NOTE: I used the root of C For this example
    objWrkBook.SaveAs outputFile & rstStates.Fields(0)
    objWrkBook.Close

  'Close the detail recordset
  rstOutput.Close
  'Move To the Next state
  rstStates.MoveNext
Loop Until rstStates.EOF

CleanUp:
objExcel.Quit 
Set objExcel = Nothing
rstStates.Close
Set rstOutput = Nothing
Set rstStates = Nothing
End Sub

 

[ehicks727]

That did the trick! Thanks JK.