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 成为 TestTable
===================================================
Dim adoConnection As New ADODB.Connection
Dim adoRecordset As New ADODB.Recordset
'OLE DB + ODBC Driver 方式:
'adoConnection.Open "Data Provider=MSDASQL.1;driver=Microsoft Excel Driver (*.xls);DBQ=e:\temp\book2.xls"
'Microsoft.Jet.OLEDB.4.0 方式,(建议)
adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=e:\temp\book2.xls;Extended Properties='Excel 8.0;HDR=Yes'"
adoRecordset.Open "select * from [sheet1$]", adoConnection, adOpenKeyset, adLockOptimistic
'注: OLE DB + ODBC Driver 方式不支持以下语句,但 Microsoft.Jet.OLEDB.4.0 方式支持!
adoConnection.Execute "insert into [sheet1$](F1) values(3)"
adoRecordset.AddNew Array("f1", "f2", "f3", "f4"), Array(1, 2, 3, 4)
Private Sub Command1_Click()
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen() '存字段长度值
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
With Data1.Recordset
.MoveLast
If .RecordCount < 1 Then
MsgBox ("Error 没有记录!")
Exit Sub
End If
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.Count '字段总数
ReDim Fieldlen(Icolcount)
.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1 '在Excel中的第一行加标题
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
Case 2 '将数组FIELDLEN()存为第一条记录的字段长
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
'如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
'Excel列宽等于字段长
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
'向Excel的CellS中写入字段值
Case Else
Fieldlen1 = LenB(.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
'表格列宽等于较长字段长
Fieldlen(Icol) = Fieldlen1
'数组Fieldlen(Icol)中存放最大字段长度值
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow <> 1 Then
If Not .EOF Then .MoveNext
End If
Next
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
xlApp.Visible = True '显示表格
xlBook.Save '保存
Set xlApp = Nothing '交还控制给Excel
End With
End Sub
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlChar As New Excel.Chart
Dim xlSheet As New Excel.Worksheet
'建立需要的对象
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("F:\BOOK1.xls")
Set xlSheet = xlBook.Worksheets(1)
'删除 退出(&X) 菜单
Dim i As Integer
For i = 1 To xlApp.CommandBars("File").Controls.Count
Debug.Print xlApp.CommandBars("File").Controls(i).Caption
If Left$(xlApp.CommandBars("File").Controls(i).Caption, 2) = "关闭" Then
xlApp.CommandBars("File").Controls(i).Visible = False 'Delete
Exit For
End If
Next