将数据库导出到 XLS：它忽略格式？

如何解决将数据库导出到 XLS：它忽略格式？

所以我有一个通过宏执行 VBA 脚本的表单。所述脚本的目的是打开 Excel，创建一个新工作簿，从多个表中收集信息并将它们导出到格式化的电子表格中。每个人都有一张写有姓名的表格，相关数据打印在该表格中。它在大多数情况下都可以完美运行。只有一个问题... Access 中收集姓名和人口统计数据的表格被格式化为按姓氏字母升序排序。 VBA 脚本按照输入名称的顺序导出它。我希望我的 VBA 脚本尊重数据库表中的格式，并且我不想在我的 VBA 脚本中添加一个按字母顺序排列的子例程。

表 A 格式：ID、Active、Last、First、Role、Traveler、Resident、Preceptee、Phone、Completion

表 B 格式：ID、课程、课程 ID、提供、HLC、课程类型

表 A 中的最后一个名为“Roster”的字段是我希望 VBA 脚本按字母顺序排序的字段。数据库已配置为执行此操作。

提前致谢！

VBA 代码：

Option Compare Database

' This module exports the database to a spreadsheet with specific formatting when called from a Macro
' Each Employee will have a sheet named thier last name which will contain all HLC modules they have completed in a list
' It is specific to this Database,but can be adapted to others.

' Version 1.0 Stable

Public Function ExportXLS(TblA As String,TblB As String,Optional names As String,Optional specific As Boolean)
'****************'
'Set up variables'
'****************'
Dim ctrA As Integer
Dim ctrB As Integer
Dim var As Long
Dim str As String

Dim excel As Object 'Pointer to Excel Application
Dim book As Object 'Pointer to Excel Workbook
Dim sheet As Object 'Pointer to Excell Sheet

Dim Roster As DAO.Recordset
Dim Course As DAO.Recordset
Dim Child As DAO.Recordset

Dim last_name As DAO.Recordset 'Matrix of pointers that will hold parts of the tables to be printed to the corresponding Excel sheets
Dim course_name As DAO.Recordset 'Matrix of pointers that will hold parts of the tables to be printed to the corresponding Excel sheets
'********************************************************'
'Initialize our tables into thier recordsets for analysis'
'********************************************************'
Set Roster = CurrentDb.OpenRecordset(TblA)
Set Course = CurrentDb.OpenRecordset(TblB)

str = "SELECT Last FROM Roster"
Set last_name = CurrentDb.OpenRecordset(str)
str = "SELECT Course FROM [Course List]"
Set course_name = CurrentDb.OpenRecordset(str)
'**************************************************************************'
'Create the new excel file with default parameters and print the cover page'
'**************************************************************************'
Set excel = CreateObject("Excel.Application")
Set book = excel.Workbooks.Add
excel.Visible = True
Set sheet = book.Worksheets("Sheet1")
str = "Coversheet"
sheet.Name = str
sheet.Range("B2") = "HLC Database Export tool V1.0"
sheet.Range("B3") = "Written by Levi T Jackson,RN,BSN"
sheet.Range("B4") = "All rights reserved,Copyright 2021"
sheet.Range("B5") = "For use only by Emory Healhtcare,and others with permissions"
'**********************************'
'Main Loop,where the magic happens'
'**********************************'
ctrA = 0
Roster.MoveFirst
last_name.MoveFirst
Do Until last_name.EOF 'Move through the list of last names in the table Roster,one at a time
    
    If Roster!Active = True Then 'No need to report on inactive employees,use access query for that
        
        Set Child = Roster!Completion.Value 'Open a Recordset for the multivalued field Completion in Roster
        ctrB = 1
        If Child.EOF = True Then 'save the number of records for printing,or set to 0
            var = 0
        Else
            Child.MoveLast
            var = Child.RecordCount
            Child.MoveFirst
        End If
        Course.MoveLast
        
        If Child.EOF = False Then 'Avoid errors by not processing a page if no completion records exist
            
            Set sheet = book.sheets.Add(After:=book.Worksheets(book.Worksheets.count)) 'For active employees,make a new sheet and switch to it,and set its name to the current last name from Roster
            sheet.Activate
            sheet.Range("A1").SELECT
            str = Roster!Last & "," & Roster!First
            sheet.Name = str
            sheet.Range("B2") = "Courses Completed"
            
            Do Until Child.EOF 'If there are records in Completion for the current name,print them,move on when done
                Course.MoveFirst
                course_name.MoveFirst
                Do Until Course.EOF
                    If Course![Course ID] = CInt(Child!Value.Value) Then
                        sheet.Range("D" & Mid(coordinates(ctrB),2,Len(coordinates(ctrB)) - 1)) = Course![Course ID] 'prints course ID next to the name
                        sheet.Range("D2") = "'" & CStr(var) & " / " & CStr(Course.RecordCount) 'Prints number of records in completions
                        sheet.Range("B3") = "Course Name"
                        sheet.Range("D3") = "Course ID"
                        sheet.Range(coordinates(ctrB)) = Course!Course 'Prints course name
                        ctrB = ctrB + 1
                        Course.MoveLast
                        Course.MoveNext
                    Else
                        Course.MoveNext
                        course_name.MoveNext
                    End If
                Loop
                Child.MoveNext
            Loop
        End If
        
        ctrA = ctrA + 1 'I might use this later in code updates,counts how manmy records are processed
        Child.Close
        excel.ActiveSheet.Cells.SELECT 'Selects all of the cells
        excel.ActiveSheet.Cells.EntireColumn.AutoFit 'Does the "autofit" for all columns
        sheet.Range("A1").SELECT 'Selects the first cell to unselect all cells
    End If
    Roster.MoveNext
    last_name.MoveNext
Loop
'Clean up recordsets
last_name.Close
course_name.Close
Roster.Close
Set Roster = Nothing
Course.Close
Set Course = Nothing
End Function

'Converts the iteration of the print course sub loop into a sheet coordinate cell and returns it as a string
'This function is here so that later a more complicated printing coordinate system can be easily added as the database grows larger

Private Function coordinates(num As Integer) As String
    coordinates = "B" & CStr(num + 4)
End Function

解决方法

在您的 OpenRecordset 语句中添加 order by 子句。