469,077 Members | 1,383 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 469,077 developers. It's quick & easy.

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

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.

Expand|Select|Wrap|Line Numbers
  1. Sub documentor()
  2. Dim db As dao.Database
  3. Dim td As dao.TableDef
  4. Dim fld As dao.Field
  5. Dim TblToDocument As String
  6. Set db = CurrentDb
  7. Set td = db.TableDefs("Supplier_Master")
  8. On Error GoTo err_handler
  9. For Each fld In td.Fields
  10.   Debug.Print fld.Name, fld.Properties("Description").Value
  11. Next
  12. Exit Sub
  13. err_handler:
  14. Select Case Err.Number
  15.     Case 3270
  16.         Debug.Print fld.Name
  17.         Resume Next
  18.     Case Else
  19.         strMsg = "An error occurred." & vbCrLf & "Error # " & Err.Number & " - " & Err.Description
  20.         MsgBox strMsg, vbExclamation
  21. End Select
  22. End Sub
  23.  
Sep 6 '16 #1
6 878
ADezii
8,800 Expert 8TB
  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.
    Expand|Select|Wrap|Line Numbers
    1. Public Sub Documentor(strTableName As String)
    2. On Error GoTo err_handler
    3. Dim db As DAO.Database
    4. Dim td As DAO.TableDef
    5. Dim fld As DAO.Field
    6. Dim strMsg As String
    7.  
    8. Set db = CurrentDb
    9. Set td = db.TableDefs(strTableName)
    10.  
    11. Open CurrentProject.Path & "\Output.txt" For Output As #1
    12.  
    13. For Each fld In td.Fields
    14.   Print #1, fld.Name & "," & fld.Properties("Description").Value
    15. Next
    16.  
    17. Close #1
    18.  
    19. Exit Sub
    20.  
    21. err_handler:
    22.   Select Case Err.Number
    23.     Case 3270
    24.       Print #1, fld.Name & "," & "NO Description"
    25.         Resume Next
    26.     Case Else
    27.       strMsg = "An error occurred." & vbCrLf & "Error # " & Err.Number & " - " & Err.Description
    28.         MsgBox strMsg, vbExclamation
    29. End Select
    30. 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:
    Expand|Select|Wrap|Line Numbers
    1. ID,NO Description
    2. Company,Company
    3. Last Name,Last Name
    4. First Name,First Name
    5. E-mail Address,NO Description
    6. Job Title,NO Description
    7. Business Phone,NO Description
    8. Home Phone,NO Description
    9. Mobile Phone,Mobile Phone
    10. Fax Number,NO Description
    11. Address,NO Description
    12. City,NO Description
    13. State/Province,NO Description
    14. ZIP/Postal Code,NO Description
    15. Country/Region,NO Description
    16. Notes,Notes
    17. Salary,NO Description
    18. 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.
Sep 6 '16 #2
PhilOfWalton
1,430 Expert 1GB
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
Sep 6 '16 #3
ADezii
8,800 Expert 8TB
Out of curiosity, Phil, is this Code executed within the context of Excel or Access?
Sep 6 '16 #4
PhilOfWalton
1,430 Expert 1GB
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

Expand|Select|Wrap|Line Numbers
  1.     With MyXL.Application
  2.         If .Worksheets(i).Name <> SheetName Then        ' Name changed
  3.             .Worksheets(i).Name = SheetName
  4.         End If
  5.         .Worksheets(i).Activate
  6.         .Range("A1:Q100").Clear
  7.         .Range("A1:Q100").Font.Size = FontSize10_9
  8.         .Range("A1:Q100").Font.Bold = False
  9.         '.Range("A1:Q6").Font.Name = "Arial"
  10.         '.Range("A7:Q100").Font.Name = "Arial Narrow"    ' To make more room
  11.         .Range("A1:Q100").Font.Name = "Arial"
  12.         .Range("H7:Q100").Font.Name = "Arial Narrow"    ' Race Results To make more room
  13.  
  14.         .Cells(1, 1).Font.Size = FontSize14_12
  15.         .Cells(1, 1).Font.Color = 255
  16.         .Cells(1, 1).Font.Bold = True
  17.         .Cells(1, 1).Value = "Overall Results " & Frm!SeriesName
  18.     End With
  19.  
  20.     ActiveSheet.Range("I1").Select
  21.     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
  22.         "http://www.pofr.freeuk.com/results.htm", TextToDisplay:="Back"
  23.  
  24.     With MyXL.Application
  25.         .Columns("A").ColumnWidth = 7                       ' Position
  26.         .Range("A9:A100").Font.Bold = True
  27.         .Columns("B").ColumnWidth = 20                      ' Boat name
  28.         .Columns("C").ColumnWidth = ColumnWidth10_9         ' Sail No
  29.         If Frm!ResultTypeIDRelay = 1 Then                   ' Combined
  30.             .Columns("D").ColumnWidth = ColumnWidth10_9     ' Division
  31.             .Columns("D").HorizontalAlignment = xlRight     ' Right
  32.         ElseIf Frm!ResultTypeIDRelay = 2 Then               ' Division
  33.             .Columns("D").ColumnWidth = 0                   ' Division
  34.         ElseIf Frm!ResultTypeIDRelay = 4 Then               ' Boat Class
  35.             .Columns("D").ColumnWidth = ColumnWidth10_9     ' Division
  36.             .Columns("D").HorizontalAlignment = xlRight     ' Right
  37.         End If
  38.         .Columns("E").ColumnWidth = 6       ' Club
  39.         .Columns("F").ColumnWidth = 6       ' Total Points
  40.         .Columns("G").ColumnWidth = 6       ' Total Ex Discards
  41.         .Columns("G").Font.Bold = True      ' Total Ex Discards
  42.         .Columns("H").ColumnWidth = ColumnWidths8Quart_7Quart      ' Races
  43.         .Columns("I").ColumnWidth = ColumnWidths8Quart_7Quart
  44.         .Columns("J").ColumnWidth = ColumnWidths8Quart_7Quart
  45.         .Columns("K").ColumnWidth = ColumnWidths8Quart_7Quart
  46.         .Columns("L").ColumnWidth = ColumnWidths8Quart_7Quart
  47.         .Columns("M").ColumnWidth = ColumnWidths8Quart_7Quart
  48.         .Columns("N").ColumnWidth = ColumnWidths8Quart_7Quart
  49.         .Columns("O").ColumnWidth = ColumnWidths8Quart_7Quart
  50.         .Columns("P").ColumnWidth = ColumnWidths8Quart_7Quart
  51.         .Columns("Q").ColumnWidth = ColumnWidths8Quart_7Quart
  52.         .Range("F7:G8").HorizontalAlignment = xlRight               ' right
  53.         .Range("H7:Q100").HorizontalAlignment = xlCenter            ' center
  54.         .Range("H7:Q100").Font.Color = 16711680                     ' blue
  55.         .Cells(2, 1).Font.Size = FontSize14_12
  56.         .Cells(2, 1).Font.Color = 255
  57.         .Cells(2, 1).Font.Bold = True
  58.         If Frm!ResultTypeIDRelay = 1 Then               ' Combined
  59.             .Cells(2, 1).Value = Frm!ResultTypeIDRelay.Column(0)
  60.             .Cells(2, 5).Value = GetTrophyName("", 1)
  61.             .Cells(2, 5).Font.Size = FontSize14_12
  62.             .Cells(2, 5).Font.Color = 255
  63.             .Cells(2, 5).Font.Bold = True
  64.         ElseIf Frm!ResultTypeIDRelay = 2 Then           ' Division
  65.             .Cells(2, 1).Value = "Division: " & StartSet!Division
  66.             .Cells(2, 5).Value = GetTrophyName(StartSet!Division, 2)
  67.             .Cells(2, 5).Font.Size = FontSize14_12
  68.             .Cells(2, 5).Font.Color = 255
  69.             .Cells(2, 5).Font.Bold = True
  70.         ElseIf Frm!ResultTypeIDRelay = 4 Then           ' Boat Class
  71.             .Cells(2, 1).Value = "Boat Class: " & StartSet!BoatClass
  72.         End If
  73.  
  74.         .Cells(4, 1).Value = Frm!RacesCompleted & " races sailed, " & Frm!RacesCounting & " to count. Discards shown in (brackets)"
  75.  
  76. Titles:
  77.         .Range("A7:Z8").Font.Size = FontSize11_10
  78.         .Range("A7:Z8").Font.Bold = True
  79.         .Cells(7, 1).Value = "Position"
  80.         .Cells(7, 2).Value = "Boat Name"
  81.         .Cells(7, 3).Value = "Sail No"
  82.         If Frm!ResultTypeIDRelay = 1 Then        ' Combimed
  83.             .Cells(7, 4).Value = "Division"
  84.         End If
  85.         If Frm!ResultTypeIDRelay = 4 Then        ' Boat Class
  86.             .Cells(7, 4).Value = "Division"
  87.         End If
  88.         .Cells(7, 5).Value = "Club"
  89.         .Cells(7, 6).Value = "Gross"
  90.         .Cells(7, 7).Value = "Nett"
  91.         .Cells(8, 6).Value = "Points"
  92.         .Cells(8, 7).Value = "Points"
  93.  
  94.     ' Find common words in the race descriptions
  95.     FirstSpacePos = 1
  96.     HoldWord = ""
  97.     TestWord = ""
  98. FirstRaceStart:
  99.     Name = Frm!SeriesName & " "             ' Add a space to get complete series name
  100.     NextSpacePos = InStr(FirstSpacePos, Name, " ")
  101.     If NextSpacePos = 0 Then GoTo RaceTitles
  102.     If HoldWord = "" Then
  103.         HoldWord = Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
  104.     Else
  105.         HoldWord = HoldWord & " " & Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
  106.     End If
  107.     k = 8
  108.  
  109. NextRaceStart:
  110.     k = k + 1
  111.     ' ResultsSet.Fields(i).Name has the form "POFR 2002 race 1 <CR> 01/06/02"
  112.     If k = ResultsSet.Fields.Count - 1 Then
  113.         FirstSpacePos = NextSpacePos + 1
  114.         TestWord = HoldWord
  115.         GoTo FirstRaceStart
  116.     End If
  117.     Name = ResultsSet.Fields(k).Name
  118.  
  119.     NextSpacePos = InStr(FirstSpacePos, Name, " ")
  120.     If TestWord = "" Then
  121.         Word = Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
  122.     Else
  123.         Word = TestWord & " " & Mid(Name, FirstSpacePos, NextSpacePos - FirstSpacePos)
  124.     End If
  125.     If Word = HoldWord Then
  126.         GoTo NextRaceStart
  127.     End If
  128.  
  129. RaceTitles:
  130.     For k = 9 To ResultsSet.Fields.Count - 1
  131.         .Cells(7, k - 1).Value = CleanRace(ResultsSet.Fields(k).Name, HoldWord, 1)
  132.         .Cells(8, k - 1).Value = CleanRace(ResultsSet.Fields(k).Name, HoldWord, 2)
  133.     Next
  134.     End With
  135.  
  136.     With ResultsSet
  137.         j = 0
  138. NextBoat:
  139.         If .EOF Then
  140.             GoTo AllDone
  141.         End If
  142.         If Frm!ResultTypeIDRelay = 2 Then          ' Division
  143.             If !Division <> HoldDivision Then
  144.                 HoldDivision = !Division
  145.                 StartSet.MoveNext
  146.                 i = i + 1
  147.                 GoTo NextStart
  148.             End If
  149.         End If
  150.  
  151.         If Frm!ResultTypeIDRelay = 4 Then          ' Boat Class
  152.             If !BoatClass <> HoldDivision Then
  153.                 HoldDivision = !BoatClass
  154.                 StartSet.MoveNext
  155.                 i = i + 1
  156.                 GoTo NextStart
  157.             End If
  158.         End If
  159.         j = j + 1
  160.         If j = 1 Then
  161.             MyXL.Application.Range("A9:G9").Font.Bold = True
  162.             MyXL.Application.Range("A9:G9").Font.Color = 255       'Red
  163.         End If
  164.         MyXL.Application.Cells(j + 8, 1).Value = !SeriesPosition
  165.         MyXL.Application.Cells(j + 8, 2).Value = UCase(!BoatName)
  166.         MyXL.Application.Cells(j + 8, 3).Value = !RacingNo
  167.         If Frm!ResultTypeIDRelay = 1 Then
  168.             MyXL.Application.Cells(j + 8, 4).Value = !Division
  169.         End If
  170.         If Frm!ResultTypeIDRelay = 4 Then
  171.             MyXL.Application.Cells(j + 8, 4).Value = !Division
  172.         End If
  173.         MyXL.Application.Cells(j + 8, 5).Value = !ClubAbbreviation
  174.         MyXL.Application.Cells(j + 8, 6).Value = !Total
  175.         MyXL.Application.Cells(j + 8, 7).Value = !TotalExDiscards
  176.         For k = 9 To ResultsSet.Fields.Count - 1
  177.             MyXL.Application.Cells(j + 8, k - 1).Value = .Fields(k)
  178.         Next k
  179.         .MoveNext
  180.         GoTo NextBoat
  181.     End With
  182.  
Phil
Sep 6 '16 #5
zmbd
5,400 Expert Mod 4TB
ADezii, change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.
Sep 6 '16 #6
ADezii
8,800 Expert 8TB
change the file name from .txt to .CSV and Excel opens the file directly - optionally add a header row.
Great point, thanks!
Sep 7 '16 #7

Post your reply

Sign in to post your reply or Sign up for a free account.

Similar topics

reply views Thread by Jason | last post: by
8 posts views Thread by DC Gringo | 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
1 post views Thread by CARIGAR | last post: by
reply views Thread by zhoujie | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.