转贴将EXECL变成ACCESS: 此一模块共有四个参数： 1、sSheetName：要导出资料的文件名称 (Sheet name)，例如 Sheet1 2、sExcelPath：要导出资料的 Excel 档案路径名称 (Workbook path)，例如 C:\book1.xls 3、sAccessTable：要导入的 Access Table 名称，例如 TestTable 4、sAccessDBPath：要导入的 Access 档案路径名称，例如 C:\Test.mdb在声明中加入以下：Private Sub ExportExcelSheetToAccess(sSheetName As String, _ sExcelPath As String, sAccessTable As String, sAccessDBPath As String) Dim db As Database Dim rs As Recordset Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0") Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & _ sAccessTable & " FROM [" & sSheetName & "$]") MsgBox "Table exported successfully.", vbInformation, "Yams" End Sub 使用范例如下：將 C:\book1.xls 中的 Sheet1 导入 C:\Test.mdb 成为 TestTableExportExcelSheetToAccess "Sheet1", "C:\book1.xls", "TestTable", "C:\Test.mdb"
我看你们理解反了，他要的时从access到excel 我以前的代码 '下一步，将数据以Excel格式输出 '创建Excel对象 Dim xlApp As Object '定义存放引用对象的变量。 Dim xlWorkBook As Object Dim xlSheet As Object Set xlApp = CreateObject("Excel.Application") '可以使用 xlApp 访问 Microsoft Excel 的其它对象。 xlApp.Visible = False '如果要让该应用程序可见，则需将 Visible 属性设为 True。 Set xlWorkBook = Nothing Set xlSheet = Nothing Set xlWorkBook = xlApp.Workbooks().Add Set xlSheet = xlWorkBook.Worksheets("sheet1") 'Excel对象创建完毕。
'下一步进行数据填充 Dim strCell As String '定义Excel中位置 xlApp.Range("a1").Value = "姓名" For i = 1 To 31 Select Case i Case 1 To 25 strCell = Chr(Asc("a") + i) & "1" Case 26 To 31 strCell = "a" & Chr(Asc("a") + i - 26) & "1" End Select xlApp.Range(strCell).Value = (i) & "日" Next i
把 Access 数据 写入 Excel 中: ============================================================ Private Sub Command1_Click() Dim cnt As New ADODB.Connection Dim rst As New ADODB.Recordset
Dim xlApp As Object Dim xlWb As Object Dim xlWs As Object Dim recArray As Variant
Dim strDB As String Dim fldCount As Integer Dim recCount As Long Dim iCol As Integer Dim iRow As Integer
' Set the string to the path of your Northwind database strDB = "c:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"
' Open connection to the database cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & strDB & ";"
' Open recordset based on Orders table rst.Open "Select * From Orders", cnt
' Create an instance of Excel and add a workbook Set xlApp = CreateObject("Excel.Application") Set xlWb = xlApp.Workbooks.Add Set xlWs = xlWb.Worksheets("Sheet1")
' Display Excel and give user control of Excel's lifetime xlApp.Visible = True xlApp.UserControl = True
' Copy field names to the first row of the worksheet fldCount = rst.Fields.Count For iCol = 1 To fldCount xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name Next
' Check version of Excel If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then 'EXCEL 2000 or 2002: Use CopyFromRecordset
' Copy the recordset to the worksheet, starting in cell A2 xlWs.Cells(2, 1).CopyFromRecordset rst 'Note: CopyFromRecordset will fail if the recordset 'contains an OLE object field or array data such 'as hierarchical recordsets
Else 'EXCEL 97 or earlier: Use GetRows then copy array to Excel
' Copy recordset to an array recArray = rst.GetRows 'Note: GetRows returns a 0-based array where the first 'dimension contains fields and the second dimension 'contains records. We will transpose this array so that 'the first dimension contains records, allowing the 'data to appears properly when copied to Excel
' Determine number of records recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array ' Check the array for contents that are not valid when ' copying the array to an Excel worksheet For iCol = 0 To fldCount - 1 For iRow = 0 To recCount - 1 ' Take care of Date fields If IsDate(recArray(iCol, iRow)) Then recArray(iCol, iRow) = Format(recArray(iCol, iRow)) ' Take care of OLE object fields or array fields ElseIf IsArray(recArray(iCol, iRow)) Then recArray(iCol, iRow) = "Array Field" End If Next iRow 'next record Next iCol 'next field
' Transpose and Copy the array to the worksheet, ' starting in cell A2 xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _ TransposeDim(recArray) End If ' Auto-fit the column widths and row heights xlApp.Selection.CurrentRegion.Columns.AutoFit xlApp.Selection.CurrentRegion.Rows.AutoFit ' Close ADO objects rst.Close cnt.Close Set rst = Nothing Set cnt = Nothing
' Release Excel references Set xlWs = Nothing Set xlWb = Nothing Set xlApp = NothingEnd Sub Function TransposeDim(v As Variant) As Variant ' Custom Function to Transpose a 0-based array (v)
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long Dim tempArray As Variant
Xupper = UBound(v, 2) Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper) For X = 0 To Xupper For Y = 0 To Yupper tempArray(X, Y) = v(Y, X) Next Y Next X
TransposeDim = tempArrayEnd Function
不要 忘了 引用 Microsoft ActiveX Data Objects 2.1 Library .
此一模块共有四个参数：
1、sSheetName：要导出资料的文件名称 (Sheet name)，例如 Sheet1
2、sExcelPath：要导出资料的 Excel 档案路径名称 (Workbook path)，例如 C:\book1.xls
3、sAccessTable：要导入的 Access Table 名称，例如 TestTable
4、sAccessDBPath：要导入的 Access 档案路径名称，例如 C:\Test.mdb在声明中加入以下：Private Sub ExportExcelSheetToAccess(sSheetName As String, _
sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & _
sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table exported successfully.", vbInformation, "Yams"
End Sub
使用范例如下：將 C:\book1.xls 中的 Sheet1 导入 C:\Test.mdb 成为 TestTableExportExcelSheetToAccess "Sheet1", "C:\book1.xls", "TestTable", "C:\Test.mdb"
我以前的代码
'下一步，将数据以Excel格式输出
'创建Excel对象
Dim xlApp As Object '定义存放引用对象的变量。
Dim xlWorkBook As Object
Dim xlSheet As Object
Set xlApp = CreateObject("Excel.Application")
'可以使用 xlApp 访问 Microsoft Excel 的其它对象。
xlApp.Visible = False '如果要让该应用程序可见，则需将 Visible 属性设为 True。
Set xlWorkBook = Nothing
Set xlSheet = Nothing
Set xlWorkBook = xlApp.Workbooks().Add
Set xlSheet = xlWorkBook.Worksheets("sheet1")
'Excel对象创建完毕。
'下一步进行数据填充
Dim strCell As String '定义Excel中位置
xlApp.Range("a1").Value = "姓名"
For i = 1 To 31
Select Case i
Case 1 To 25
strCell = Chr(Asc("a") + i) & "1"
Case 26 To 31
strCell = "a" & Chr(Asc("a") + i - 26) & "1"
End Select
xlApp.Range(strCell).Value = (i) & "日"
Next i
strCell = "af" & (intRow + 1)
xlApp.Range("a2:" & strCell).Value = Report
'填充完毕，保存结果到文件
xlWorkBook.SaveAs txtOutputFile.Text
xlApp.Quit '完成时，调用 Quit 方法关闭
Set xlApp = Nothing '该应用程序，然后释放该引用。
Unload frmNotice MsgBox "处理结果已经生成！", vbOKOnly + vbInformation, "提示"
============================================================
Private Sub Command1_Click()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim recArray As Variant
Dim strDB As String
Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer
' Set the string to the path of your Northwind database
strDB = "c:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"
' Open connection to the database
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDB & ";"
' Open recordset based on Orders table
rst.Open "Select * From Orders", cnt
' Create an instance of Excel and add a workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("Sheet1")
' Display Excel and give user control of Excel's lifetime
xlApp.Visible = True
xlApp.UserControl = True
' Copy field names to the first row of the worksheet
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next
' Check version of Excel
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
'EXCEL 2000 or 2002: Use CopyFromRecordset
' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 1).CopyFromRecordset rst
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets
Else
'EXCEL 97 or earlier: Use GetRows then copy array to Excel
' Copy recordset to an array
recArray = rst.GetRows
'Note: GetRows returns a 0-based array where the first
'dimension contains fields and the second dimension
'contains records. We will transpose this array so that
'the first dimension contains records, allowing the
'data to appears properly when copied to Excel
' Determine number of records recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
' Check the array for contents that are not valid when
' copying the array to an Excel worksheet
For iCol = 0 To fldCount - 1
For iRow = 0 To recCount - 1
' Take care of Date fields
If IsDate(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = Format(recArray(iCol, iRow))
' Take care of OLE object fields or array fields
ElseIf IsArray(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = "Array Field"
End If
Next iRow 'next record
Next iCol 'next field
' Transpose and Copy the array to the worksheet,
' starting in cell A2
xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
TransposeDim(recArray)
End If ' Auto-fit the column widths and row heights
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit ' Close ADO objects
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
' Release Excel references
Set xlWs = Nothing
Set xlWb = Nothing Set xlApp = NothingEnd Sub
Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArrayEnd Function