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
-
6 939 - 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.
- 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
- 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
- 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.
- The Hard Way is writing directly to an Excel File from within the Documentor() Sub-Routine using Automation Code.
- 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.
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
Out of curiosity, Phil, is this Code executed within the context of Excel or Access?
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 5,501
Expert Mod 4TB
ADezii, change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.
change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.
Great point, thanks!
Post your reply Sign in to post your reply or Sign up for a free account.
Similar topics
3 posts
views
Thread by Saur |
last post: by
|
reply
views
Thread by Jason |
last post: by
|
6 posts
views
Thread by Robin Cushman |
last post: by
|
3 posts
views
Thread by John |
last post: by
|
8 posts
views
Thread by DC Gringo |
last post: by
|
reply
views
Thread by kieran |
last post: by
|
13 posts
views
Thread by Hemant Sipahimalani |
last post: by
|
reply
views
Thread by siLver |
last post: by
|
1 post
views
Thread by JawzX01 |
last post: by
| | | | | | | | | | | |