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

Question

我试图将do-loop生成的六个记录集导出到使用VBA的单个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:DatabaseRoster.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打开然后关闭，然后再用下一个选项卡重复该过程，但是必须有一种更优雅的方式。

excel中多个迭代的图像

**作为附带说明，在找到此论坛之前，我也将这个问题发布给答案。Microsoft.com。对不起。**

预先感谢Erik

Answer 1

为每个工作簿打开，您可以检查安全性并重置它，以便进行编辑：

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

Answer 2

正如预期的那样，这是一系列小问题，导致MS Excel将工作簿文件固定在仅读取状态后，该功能会出错。在仔细检查每行代码以查找失败的单个线路后解决。

Answer 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