将数据从Access 2010导出到Excel 2013

Question

我正在使用记录集将数据从Access导出到Excel，以将访问查询中的数据传输到Excel（因为我必须使用transferSpreadsheet无法完成的手动格式设置），同时我正在使用代码

with sheet1 
.range("A2").CopyRecordset rs1 
End With 

这工作得很好，直到3张，但是当我开始第4片（以Excel默认有3张）

Set sheet4 = wb.Worksheets.Add 

我收到一个错误说

下标超出范围错误。

有人可以帮我解决这个问题吗？

Answer 1

哪一行错误 - 添加工作表？

代码工作对我来说：

设置Sheet4 = Sheets.Add

也许发表您的全过程进行分析。

Answer 2

没有看到代码，无法肯定地说。也许工作表名称拼写错误。只是一个猜测。尝试下面的代码示例以了解如何执行此类任务的一些不同方法。

'************* Code Start ***************** 
'This code was originally written by Dev Ashish 
'It is not to be altered or distributed, 
'except as part of an application. 
'You are free to use it in any application, 
'provided the copyright notice is left unchanged. 
' 
'Code Courtesy of 
'Dev Ashish 
' 
Sub sCopyFromRS() 
'Send records to the first 
'sheet in a new workbook 
' 
Dim rs As Recordset 
Dim intMaxCol As Integer 
Dim intMaxRow As Integer 
Dim objXL As Excel.Application 
Dim objWkb As Workbook 
Dim objSht As Worksheet 
    Set rs = CurrentDb.OpenRecordset("Customers", _ 
        dbOpenSnapshot) 
    intMaxCol = rs.Fields.Count 
    If rs.RecordCount > 0 Then 
    rs.MoveLast: rs.MoveFirst 
    intMaxRow = rs.RecordCount 
    Set objXL = New Excel.Application 
    With objXL 
     .Visible = True 
     Set objWkb = .Workbooks.Add 
     Set objSht = objWkb.Worksheets(1) 
     With objSht 
     .Range(.Cells(1, 1), .Cells(intMaxRow, _ 
      intMaxCol)).CopyFromRecordset rs 
     End With 
    End With 
    End If 
End Sub 

Sub sCopyRSExample() 
'Copy records to first 20000 rows 
'in an existing Excel Workbook and worksheet 
' 
Dim objXL As Excel.Application 
Dim objWkb As Excel.Workbook 
Dim objSht As Excel.Worksheet 
Dim db As Database 
Dim rs As Recordset 
Dim intLastCol As Integer 
Const conMAX_ROWS = 20000 
Const conSHT_NAME = "SomeSheet" 
Const conWKB_NAME = "J:\temp\book1.xls" 
    Set db = CurrentDb 
    Set objXL = New Excel.Application 
    Set rs = db.OpenRecordset("Customers", dbOpenSnapshot) 
    With objXL 
    .Visible = True 
    Set objWkb = .Workbooks.Open(conWKB_NAME) 
    On Error Resume Next 
    Set objSht = objWkb.Worksheets(conSHT_NAME) 
    If Not Err.Number = 0 Then 
     Set objSht = objWkb.Worksheets.Add 
     objSht.Name = conSHT_NAME 
    End If 
    Err.Clear 
    On Error GoTo 0 
    intLastCol = objSht.UsedRange.Columns.Count 
    With objSht 
     .Range(.Cells(1, 1), .Cells(conMAX_ROWS, _ 
      intLastCol)).ClearContents 
     .Range(.Cells(1, 1), _ 
     .Cells(1, rs.Fields.Count)).Font.Bold = True 
     .Range("A2").CopyFromRecordset rs 
    End With 
    End With 
    Set objSht = Nothing 
    Set objWkb = Nothing 
    Set objXL = Nothing 
    Set rs = Nothing 
    Set db = Nothing 
End Sub 

Sub sCopyRSToNamedRange() 
'Copy records to a named range 
'on an existing worksheet on a 
'workbook 
' 
Dim objXL As Excel.Application 
Dim objWkb As Excel.Workbook 
Dim objSht As Excel.Worksheet 
Dim db As Database 
Dim rs As Recordset 
Const conMAX_ROWS = 20000 
Const conSHT_NAME = "SomeSheet" 
Const conWKB_NAME = "c:\temp\book1.xls" 
Const conRANGE = "RangeForRS" 

    Set db = CurrentDb 
    Set objXL = New Excel.Application 
    Set rs = db.OpenRecordset("Customers", dbOpenSnapshot) 
    With objXL 
    .Visible = True 
    Set objWkb = .Workbooks.Open(conWKB_NAME) 
    On Error Resume Next 
    Set objSht = objWkb.Worksheets(conSHT_NAME) 
    If Not Err.Number = 0 Then 
     Set objSht = objWkb.Worksheets.Add 
     objSht.Name = conSHT_NAME 
    End If 
    Err.Clear 
    On Error GoTo 0 
    objSht.Range(conRANGE).CopyFromRecordset rs 
    End With 
    Set objSht = Nothing 
    Set objWkb = Nothing 
    Set objXL = Nothing 
    Set rs = Nothing 
    Set db = Nothing 
End Sub 
'************* Code End *****************