使用 VBA 将 MS Access 记录集导出到 Excel 中的多个工作表/选项卡会生成只读文件

Posted 2023-05-07

【中文标题】使用 VBA 将 MS Access 记录集导出到 Excel 中的多个工作表/选项卡会生成只读文件

【英文标题】：Exporting MS Access recordsets to multiple worksheets/tabs in Excel results in Read-Only files Using VBA

【发布时间】：2018-02-10 13:19:54

【问题描述】：

我正在尝试使用 VBA 将 Do-Loop 生成的六个记录集导出到单个 MS Excel 工作簿中的六个特定选项卡。但是，该代码没有更新单个选项卡，而是创建了工作簿的六个开放迭代，其中只有第一个是可编辑的，其余的是只读的。记录集以所需格式成功导出到正确的选项卡中。

Function ExportRecordset2XLS2(ByVal rs As DAO.Recordset, strSheetName)
Dim xls As Object
Dim xlwb As Object
Dim xlws As Object
Dim fld As DAO.Field
Dim strPath As String07
Dim strTitleRange,strHeaderRange, strBodyRange as String

On Error GoTo err_handler

strPath = "C:\Database\Roster.xlsx"
Set xls = CreateObject("Excel.Application")
Set xlwb = xls.Workbooks.Open(strPath)

xls.Visible = False
xls.ScreenUpdating = False
Set xlws = xlwb.Worksheets(strSheetName)
xlws.Activate

'Define ranges for formatting
    intFields = rs.Fields.Count
    intRows = rs.RecordCount
    strTitleRange = "A1:" & Chr(64 + intFields) & "1"
    strHeaderRange = "A2:" & Chr(64 + intFields) & "2"
    strBodyRange = "A3:" & Chr(64 + intFields) & (intRows + 2)

'Build TITLE Row
    xlws.Range("A1").Select 
    xls.ActiveCell = Format(Now(), "YYYY") & " Roster (" & strSheetName & ")"

'Build HEADER Row
    xlws.Range("A2").Select

For Each fld In rs.Fields
    xls.ActiveCell = fld.Name
    xls.ActiveCell.Offset(0, 1).Select
Next

rs.MoveFirst

'Paste Recordset into Worksheet(strSheetName) starting in A3
    xlws.Range("A3").CopyFromRecordset rs

On Error Resume Next
xls.Visible = True   'Make excel visible to the user
Set rs = Nothing
Set xlws = Nothing
Set xlwb = Nothing
xls.ScreenUpdating = True
Set xls = Nothing
xls.Quit

Exit Function

err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function
End Function

我怀疑问题在于函数如何打开 .xlsx 文件进行编辑；我尝试以各种方式和顺序以编程方式关闭活动工作表和/或工作簿，但没有效果。我大概可以在生成记录集的代码中插入一个中断，以允许 MS Excel 打开然后关闭，然后使用下一个选项卡重复该过程，但必须有一种更优雅的方式。

Image of multiple iterations in Excel

** 作为附注，在找到这个论坛之前，我确实也将这个问题发布到了 answers.microsoft.com。对不起。 **

提前致谢，埃里克

【问题讨论】：

您可以使用“数据”选项卡>“从 Access”，然后在需要最新数据时全部刷新

【参考方案1】：

对于每个打开的工作簿，您都可以检查安全性并将其重置以便可以对其进行编辑：

            If Application.ProtectedViewWindows.Count > 0 Then
                Application.ActiveProtectedViewWindow.Edit
            End If

【讨论】：

谢谢@Jan，但没有改变。它在概念上看起来很有希望，但该函数仍然打开同一工作簿的多个只读迭代 - 每个都打开新更新的工作表，但不反映更新另一个工作表所产生的更改。

VBA 在查看受限工作簿时是否处于活动状态？

Yes & No。当初始函数（未显示）将第一个记录集放到 ExportRecordset2XLS2 函数时，MS Excel 将关闭。所以不行。由于第一个函数继续循环通过 do-loop 创建自定义记录集，Excel 将在那时处于活动状态。所以是的。初始函数创建 5 个记录集以导出到这些特定选项卡。

附带说明，当我今天早上重新启动笔记本电脑时，Windows 启动了 30 个 MS Excel 实例，这让我相信我没有以编程方式正确关闭 MS Excel，留下一堆进程悬空。

我通过在错误处理程序中添加脚本来关闭并退出 excel 解决了后面的问题，所以我没有让任何进程悬空... err_handler: DoCmd.SetWarnings True MsgBox Err.Description, vbExclamation, Err.Number xlwb.Close xls.Quit 退出函数

【参考方案2】：

正如预期的那样，这是一系列小问题，导致 MS Excel 在函数出错后将工作簿文件保持在只读状态。在仔细检查每一行代码以找到失败的个别行后解决。

【参考方案3】：

试试这个方法和反馈。

Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String

' Replace PutEXCELFileNameHereWithoutdotxls with actual EXCEL
' filename without the .xls extension
' (for example, MyEXCELFileName, BUT NOT MyEXCELFileName.xls)
Const strFileName As String = "PutEXCELFileNameHereWithoutdotxls"

Const strQName As String = "zExportQuery"

Set dbs = CurrentDb

' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each manager's identification)
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID and EmployeesTable need to
' *** be changed to your table and field names
' Get list of ManagerID values -- note: replace my generic table and field names
' with the real names of the EmployeesTable table and the ManagerID field
strSQL = "SELECT DISTINCT ManagerID FROM EmployeesTable;"
Set rstMgr = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

' Now loop through list of ManagerID values and create a query for each ManagerID
' so that the data can be exported -- the code assumes that the actual names
' of the managers are in a lookup table -- again, replace generic names with
' real names of tables and fields
If rstMgr.EOF = False And rstMgr.BOF = False Then
      rstMgr.MoveFirst
      Do While rstMgr.EOF = False

' *** code to set strMgr needs to be changed to conform to your
' *** database design -- ManagerNameField, ManagersTable, and
' *** ManagerID need to be changed to your table and field names
' *** be changed to your table and field names
            strMgr = DLookup("ManagerNameField", "ManagersTable", _
                  "ManagerID = " & rstMgr!ManagerID.Value)

' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID, EmployeesTable need to
' *** be changed to your table and field names
            strSQL = "SELECT * FROM EmployeesTable WHERE " & _
                  "ManagerID = " & rstMgr!ManagerID.Value & ";"
            Set qdf = dbs.QueryDefs(strTemp)
            qdf.Name = "q_" & strMgr
            strTemp = qdf.Name
            qdf.SQL = strSQL
            qdf.Close
            Set qdf = Nothing

' Replace C:\FolderName\ with actual path
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
                  strTemp, "C:\FolderName\" & strFileName & ".xls"
            rstMgr.MoveNext
      Loop
End If

rstMgr.Close
Set rstMgr = Nothing

dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing

【讨论】：

我怀疑这在问题之后没有得到解决，这是文件写入访问问题。导出部分很简单。不过，我会在几分钟内试一试。感谢您的意见。