' Dim excel_app As excel.Application
' Dim excel_sheet As excel.Sheets
Dim excel_app As Object
Dim excel_sheet As Object
Dim rs As ADODB.Recordset
Dim strsql As String
Dim pubconn As ADODB.Connection
Dim exfieldA As String
Dim exfieldB As String
Dim exfieldC As String
Dim exfieldD As String
'打開數據庫
Set rs = New ADODB.Recordset
Set pubconn = New ADODB.Connection
pubconn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=aaa;Data Source=(local)"
pubconn.Open
Set excel_app = CreateObject("excel.application") 'excel對象
Set excel_app = New Excel.Application
' excel_app.Visible = True
excel_app.Workbooks.Open FileName:="D:\astroboy\河南生稅務支持系統\實現\字典\111.xls"
' excel_app.Worksheets(Combo1.ListIndex + 1).Activate
If Val(excel_app.Application.Version) >= 8 Then '檢查excel文件的版本
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
'''創建sql表格
Dim crtstrsql As String
Dim exceltst As String
exceltst = Text1.Text
exfieldA = Trim$(excel_sheet.Cells(1, 1))
exfieldB = Trim$(excel_sheet.Cells(1, 2))
exfieldC = Trim$(excel_sheet.Cells(1, 3))
exfieldD = Trim$(excel_sheet.Cells(1, 4))
crtstrsql = ""
crtstrsql = crtstrsql & "create table " & exceltst & "(" & vbCrLf
crtstrsql = crtstrsql & exfieldA & " char(50) null," & vbCrLf
crtstrsql = crtstrsql & exfieldB & " char(6) null," & vbCrLf
crtstrsql = crtstrsql & exfieldC & " datetime null," & vbCrLf
crtstrsql = crtstrsql & exfieldD & " datetime null)"
pubconn.Execute crtstrsql
Dim new_value1 As String
Dim new_value2 As String
Dim new_value3 As String
Row = 2
Do
new_value = Trim$(excel_sheet.Cells(Row, 1)) '讀取excel工作者第壹列數據
new_value1 = Trim$(excel_sheet.Cells(Row, 2))
If excel_sheet.Cells(Row, 3) = "" Then
new_value2 = ""
Else
new_value2 = CDate(excel_sheet.Cells(Row, 3) & "1月")
End If
If excel_sheet.Cells(Row, 4) = "" Then
new_value3 = ""
Else
new_value3 = CDate(excel_sheet.Cells(Row, 4) & "1月")
End If
If Len(new_value) = 0 And Len(new_value1) = 0 Then Exit Do
'將這壹值插入SQL數據庫
strsql = "insert into " & exceltst & "(" & exfieldA & "," & exfieldB & "," & exfieldC & "," & exfieldD & ") values('" & new_value & "','" & new_value1 & "','" & new_value2 & "','" & new_value3 & "')"
pubconn.Execute strsql
Row = Row + 1 '讀取下壹行數據
Loop
MsgBox "傳輸數據完成！", vbOKOnly, "完成！"
pubconn.Close
excel_app.Quit
Set rs = Nothing
Set pubconn = Nothing
Set excel_app = Nothing
Set excel_sheet = Nothing
End Sub
或參考以下
EXCEL文件要設置固定格式，還要設置命名範圍，然後才可以導入
大致思路如下：
'// 設置打開 EXCEL 文件的連接字符串
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=excel文件名;Extended Properties=Excel 8.0"
'// 以記錄集的形式打開 Excel 文件，adoConn 為 ADODB.Connection 對象
adoConn.Open strConn
'// 將數據插入到指定的表中（以ODBC的方式打開SQL數據庫）
strSQL = "INSERT INTO [odbc;Driver={SQL Server};Server=服務器IP;Database=數據庫;UID=用戶名;PWD=密碼].SQL中的表名 SELECT EXCEL中的字段 FROM EXCEL工作表名"
'// 執行導入語句
adoConn.Execute strSQL, , adExecuteNoRecords