Ms access 将数据从Access 2010导出到Excel 2013
我正在使用记录集将数据从Access导出到Excel,以将数据从Access查询传输到Excel(因为我必须手动格式化,这是transferSpreadsheet无法完成的),并且我正在使用代码Ms access 将数据从Access 2010导出到Excel 2013,ms-access,vba,export-to-excel,Ms Access,Vba,Export To Excel,我正在使用记录集将数据从Access导出到Excel,以将数据从Access查询传输到Excel(因为我必须手动格式化,这是transferSpreadsheet无法完成的),并且我正在使用代码 with sheet1 .range("A2").CopyRecordset rs1 End With 这在3张工作表之前可以正常工作,但当我启动第4张工作表时(因为Excel默认有3张工作表) 我听到一个错误,说 下标超出范围错误 有人能帮我解决同样的问题吗?哪行错误-添加工作表 代码适用于我: 设
with sheet1
.range("A2").CopyRecordset rs1
End With
这在3张工作表之前可以正常工作,但当我启动第4张工作表时(因为Excel默认有3张工作表)
我听到一个错误,说
下标超出范围错误
有人能帮我解决同样的问题吗?哪行错误-添加工作表 代码适用于我: 设置Sheet4=工作表。添加
可能会发布完整的分析过程。如果没有看到代码,就无法确定。工作表名称可能拼写错误。只是猜测而已。尝试下面的代码示例,了解如何执行此类任务的一些不同方法
'************* 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 *****************
'************* 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 *****************