VB+Access数据导出问题

[twodollars]

如何在VB中将Access的mdb中某个Sheet的数据导出至Excel?

[twodollars]

to yoki(小马哥)
你这里的db是否是指一个connection?

[luzufu]

很多这样的例子，你可以找找，
On Error GoTo Err1
With Rs
If .State = adStateOpen Then .Close
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = CreatSql
.Open
End With
'对记录进行快速添加到excel 中去
If Rs.RecordCount = 0 Then
MsgBox "没有记录", 48, "平衡力量管理信息系统"
Exit Sub
End If
'启动excel程序
Set Excel = GetObject(, "Excel.Application") ' Create Excel Object.
Set ExcelWBk = Nothing
Set ExcelWS = Nothing
Set ExcelWBk = Excel.Workbooks.Add 'Add this Workbook to Excel.
Set ExcelWS = ExcelWBk.Worksheets("sheet1") ' Add this sheet to this Workbook
'ExcelWBk.Worksheets("sheet1").name = "Data"
Excel.Visible = False
'添加数据到excel
'-------------

Me.MousePointer = 11
'---------------添加数据
Set ExcelQuery = ExcelWS.QueryTables.Add(Rs, ExcelWS.Range("a1"))
With ExcelQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
ExcelQuery.Refresh
Me.MousePointer = 0
Excel.Visible = True
Set Excel = Nothing
Set ExcelWBk = Nothing
Set ExcelWS = Nothing
Exit Sub
Err1:
MsgBox err.Description, 48, Me.Caption
Me.MousePointer = 0
Set Excel = Nothing
Set ExcelWBk = Nothing
Set ExcelWS = Nothing
Exit Sub

[victorycyz]

mdb文件中有sheet吗？

[yoki]

Public Sub MdbToxls(sAccessFileName As String, sExcelPath As String, sSheetName As String, sAccessTable As String)
Dim db As DAO.Database

Set db = Workspaces(0).OpenDatabase(sAccessFileName)
db.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & sExcelPath & "].[" & sSheetName & "] FROM [" & sAccessTable & "]"
db.Close
Set db = Nothing
End Sub

[yoki]

Public Sub MdbToxls(sAccessFileName As String, sExcelPath As String, sSheetName As String, sAccessTable As String)
'cAccessFileName Access文件全路径 如:c:\temp\test1.mdb
'sExcelPath Excel文件的全路径 如:c:\temp\test2.xls
'sSheetName Excel中的工作簿名 如：$Sheet1
'sAccessTable Access数据库中的表 如:Table1
'调用：Call MdbToxls("c:\temp\test1.mdb","c:\temp\test2.xls","$Sheet1","Table1")
'结果：将C:\temp\test1.mdb中的Table1表导入到c:\temp\test2.xls的$Sheet1中

Dim db As DAO.Database

Set db = Workspaces(0).OpenDatabase(sAccessFileName)
db.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & sExcelPath & "].[" & sSheetName & "] FROM [" & sAccessTable & "]"
db.Close
Set db = Nothing
End Sub

[rednod]

up