How can I get a VBA module to export the results to Excel

[mathiga33]

Hi,
I have some VBA code that when ran returns the Fields available and description of a specific table.

Is it possible to now get this to export/print to excel?
Thanks in advance. Here is the code that I am using.

Sub documentor()
Dim db As dao.Database
Dim td As dao.TableDef
Dim fld As dao.Field
Dim TblToDocument As String
Set db = CurrentDb
Set td = db.TableDefs("Supplier_Master")
On Error GoTo err_handler
For Each fld In td.Fields
  Debug.Print fld.Name, fld.Properties("Description").Value
Next
Exit Sub
err_handler:
Select Case Err.Number
    Case 3270
        Debug.Print fld.Name
        Resume Next
    Case Else
        strMsg = "An error occurred." & vbCrLf & "Error # " & Err.Number & " - " & Err.Description
        MsgBox strMsg, vbExclamation
End Select
End Sub
 

[ADezii]

1. I do not think that there is a direct Method to Export the Results of a Sub-Routine to an Excel Spreadsheet but there are at least two ways that it can be done, one easy, and one more difficult.
2. For the easy one, modify your Sub-Routine as listed below, passing to it the Table you wish to analyze.
   

   Public Sub Documentor(strTableName As String)
   On Error GoTo err_handler
   Dim db As DAO.Database
   Dim td As DAO.TableDef
   Dim fld As DAO.Field
   Dim strMsg As String
    
   Set db = CurrentDb
   Set td = db.TableDefs(strTableName)
    
   Open CurrentProject.Path & "\Output.txt" For Output As #1
    
   For Each fld In td.Fields
     Print #1, fld.Name & "," & fld.Properties("Description").Value
   Next
    
   Close #1
    
   Exit Sub
    
   err_handler:
     Select Case Err.Number
       Case 3270
         Print #1, fld.Name & "," & "NO Description"
           Resume Next
       Case Else
         strMsg = "An error occurred." & vbCrLf & "Error # " & Err.Number & " - " & Err.Description
           MsgBox strMsg, vbExclamation
   End Select
   End Sub

3. For this Demo I passed the Employees Table of the Northwind Sample DB to the Routine. The Routine then generates a Comma-Delimited File of every Field along with its Description (NO Description for none) in the Project's Path. The Sample Output looks like:
   

   ID,NO Description
   Company,Company
   Last Name,Last Name
   First Name,First Name
   E-mail Address,NO Description
   Job Title,NO Description
   Business Phone,NO Description
   Home Phone,NO Description
   Mobile Phone,Mobile Phone
   Fax Number,NO Description
   Address,NO Description
   City,NO Description
   State/Province,NO Description
   ZIP/Postal Code,NO Description
   Country/Region,NO Description
   Notes,Notes
   Salary,NO Description
   DOB,DOB

4. Now, Open Excel, select the Data Tab ==> Get External Data ==> From Text, etc. The 2-Column Text File will now be Imported smoothly into Excel.
5. The Hard Way is writing directly to an Excel File from within the Documentor() Sub-Routine using Automation Code.
6. Your choice.

P.S. - In hindsight, create a Table with only two Fields, [MyField] and [MyDescription] and populate it from within the Documentor() Sub-Routine. Also within this Routine, Export the Table to Excel using TransferSpreadsheet.

[PhilOfWalton]

There is a third way and that is to control every cell in an Excel worksheet. It's a lot of coding, but it can be done.

Phil

[ADezii]

Out of curiosity, Phil, is this Code executed within the context of Excel or Access?

[PhilOfWalton]

Purely within Access.

Some sample code, sorry, cant remember whether it applies to the image looks like this. Anyway, it will give you the idea

    With MyXL.Application
        If .Worksheets(i).Name <> SheetName Then        ' Name changed
            .Worksheets(i).Name = SheetName
        End If
        .Worksheets(i).Activate
        .Range("A1:Q100").Clear
        .Range("A1:Q100").Font.Size = FontSize10_9
        .Range("A1:Q100").Font.Bold = False
        '.Range("A1:Q6").Font.Name = "Arial"
        '.Range("A7:Q100").Font.Name = "Arial Narrow"    ' To make more room
        .Range("A1:Q100").Font.Name = "Arial"
        .Range("H7:Q100").Font.Name = "Arial Narrow"    ' Race Results To make more room
 
        .Cells(1, 1).Font.Size = FontSize14_12
        .Cells(1, 1).Font.Color = 255
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 1).Value = "Overall Results " & Frm!SeriesName
    End With
 
    ActiveSheet.Range("I1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        "http://www.pofr.freeuk.com/results.htm", TextToDisplay:="Back"
 
    With MyXL.Application
        .Columns("A").ColumnWidth = 7                       ' Position
        .Range("A9:A100").Font.Bold = True
        .Columns("B").ColumnWidth = 20                      ' Boat name
        .Columns("C").ColumnWidth = ColumnWidth10_9         ' Sail No
        If Frm!ResultTypeIDRelay = 1 Then                   ' Combined
            .Columns("D").ColumnWidth = ColumnWidth10_9     ' Division
            .Columns("D").HorizontalAlignment = xlRight     ' Right
        ElseIf Frm!ResultTypeIDRelay = 2 Then               ' Division
            .Columns("D").ColumnWidth = 0                   ' Division
        ElseIf Frm!ResultTypeIDRelay = 4 Then               ' Boat Class
            .Columns("D").ColumnWidth = ColumnWidth10_9     ' Division
            .Columns("D").HorizontalAlignment = xlRight     ' Right
        End If
        .Columns("E").ColumnWidth = 6       ' Club
        .Columns("F").ColumnWidth = 6       ' Total Points
        .Columns("G").ColumnWidth = 6       ' Total Ex Discards
        .Columns("G").Font.Bold = True      ' Total Ex Discards
        .Columns("H").ColumnWidth = ColumnWidths8Quart_7Quart      ' Races
        .Columns("I").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("J").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("K").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("L").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("M").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("N").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("O").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("P").ColumnWidth = ColumnWidths8Quart_7Quart
        .Columns("Q").ColumnWidth = ColumnWidths8Quart_7Quart
        .Range("F7:G8").HorizontalAlignment = xlRight               ' right
        .Range("H7:Q100").HorizontalAlignment = xlCenter            ' center
        .Range("H7:Q100").Font.Color = 16711680                     ' blue
        .Cells(2, 1).Font.Size = FontSize14_12
        .Cells(2, 1).Font.Color = 255
        .Cells(2, 1).Font.Bold = True
        If Frm!ResultTypeIDRelay = 1 Then               ' Combined
            .Cells(2, 1).Value = Frm!ResultTypeIDRelay.Column(0)
            .Cells(2, 5).Value = GetTrophyName("", 1)
            .Cells(2, 5).Font.Size = FontSize14_12
            .Cells(2, 5).Font.Color = 255
            .Cells(2, 5).Font.Bold = True
        ElseIf Frm!ResultTypeIDRelay = 2 Then           ' Division
            .Cells(2, 1).Value = "Division: " & StartSet!Division
            .Cells(2, 5).Value = GetTrophyName(StartSet!Division, 2)
            .Cells(2, 5).Font.Size = FontSize14_12
            .Cells(2, 5).Font.Color = 255
            .Cells(2, 5).Font.Bold = True
        ElseIf Frm!ResultTypeIDRelay = 4 Then           ' Boat Class
            .Cells(2, 1).Value = "Boat Class: " & StartSet!BoatClass
        End If
 
        .Cells(4, 1).Value = Frm!RacesCompleted & " races sailed, " & Frm!RacesCounting & " to count. Discards shown in (brackets)"
 
Titles:
        .Range("A7:Z8").Font.Size = FontSize11_10
        .Range("A7:Z8").Font.Bold = True
        .Cells(7, 1).Value = "Position"
        .Cells(7, 2).Value = "Boat Name"
        .Cells(7, 3).Value = "Sail No"
        If Frm!ResultTypeIDRelay = 1 Then        ' Combimed
            .Cells(7, 4).Value = "Division"
        End If
        If Frm!ResultTypeIDRelay = 4 Then        ' Boat Class
            .Cells(7, 4).Value = "Division"
        End If
        .Cells(7, 5).Value = "Club"
        .Cells(7, 6).Value = "Gross"
        .Cells(7, 7).Value = "Nett"
        .Cells(8, 6).Value = "Points"
        .Cells(8, 7).Value = "Points"
 
    ' Find common words in the race descriptions
    FirstSpacePos = 1
    HoldWord = ""
    TestWord = ""
FirstRaceStart:
    Name = Frm!SeriesName & " "             ' Add a space to get complete series name
    NextSpacePos = InStr(FirstSpacePos, Name, " ")
    If NextSpacePos = 0 Then GoTo RaceTitles
    If HoldWord = "" Then
        HoldWord = Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
    Else
        HoldWord = HoldWord & " " & Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
    End If
    k = 8
 
NextRaceStart:
    k = k + 1
    ' ResultsSet.Fields(i).Name has the form "POFR 2002 race 1 <CR> 01/06/02"
    If k = ResultsSet.Fields.Count - 1 Then
        FirstSpacePos = NextSpacePos + 1
        TestWord = HoldWord
        GoTo FirstRaceStart
    End If
    Name = ResultsSet.Fields(k).Name
 
    NextSpacePos = InStr(FirstSpacePos, Name, " ")
    If TestWord = "" Then
        Word = Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
    Else
        Word = TestWord & " " & Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
    End If
    If Word = HoldWord Then
        GoTo NextRaceStart
    End If
 
RaceTitles:
    For k = 9 To ResultsSet.Fields.Count - 1
        .Cells(7, k - 1).Value = CleanRace(ResultsSet.Fields(k).Name, HoldWord, 1)
        .Cells(8, k - 1).Value = CleanRace(ResultsSet.Fields(k).Name, HoldWord, 2)
    Next
    End With
 
    With ResultsSet
        j = 0
NextBoat:
        If .EOF Then
            GoTo AllDone
        End If
        If Frm!ResultTypeIDRelay = 2 Then          ' Division
            If !Division <> HoldDivision Then
                HoldDivision = !Division
                StartSet.MoveNext
                i = i + 1
                GoTo NextStart
            End If
        End If
 
        If Frm!ResultTypeIDRelay = 4 Then          ' Boat Class
            If !BoatClass <> HoldDivision Then
                HoldDivision = !BoatClass
                StartSet.MoveNext
                i = i + 1
                GoTo NextStart
            End If
        End If
        j = j + 1
        If j = 1 Then
            MyXL.Application.Range("A9:G9").Font.Bold = True
            MyXL.Application.Range("A9:G9").Font.Color = 255       'Red
        End If
        MyXL.Application.Cells(j + 8, 1).Value = !SeriesPosition
        MyXL.Application.Cells(j + 8, 2).Value = UCase(!BoatName)
        MyXL.Application.Cells(j + 8, 3).Value = !RacingNo
        If Frm!ResultTypeIDRelay = 1 Then
            MyXL.Application.Cells(j + 8, 4).Value = !Division
        End If
        If Frm!ResultTypeIDRelay = 4 Then
            MyXL.Application.Cells(j + 8, 4).Value = !Division
        End If
        MyXL.Application.Cells(j + 8, 5).Value = !ClubAbbreviation
        MyXL.Application.Cells(j + 8, 6).Value = !Total
        MyXL.Application.Cells(j + 8, 7).Value = !TotalExDiscards
        For k = 9 To ResultsSet.Fields.Count - 1
            MyXL.Application.Cells(j + 8, k - 1).Value = .Fields(k)
        Next k
        .MoveNext
        GoTo NextBoat
    End With
 

Phil

[zmbd]

ADezii, change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.

[ADezii]

change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.

Great point, thanks!