求如何在VB中将excel数据导入 Access和 MSSQL

[bg4rhm]

需要将excel数据导入,文件多.文件格式统一.
需要导入Access和 MSSQL数据库

[ha1ha1ha]

Dim cgk As New ADODB.Recordset
Dim cgkup As New ADODB.Recordset
Dim cgksql, cgkupsql As String
Dim zd0, zd1, zd2, zd3, zd4 As String
Dim thsj, thsjxs As Integer
Dim jehz As Double
Private Sub Command1_Click()
Dim excel_app As Object
Dim excel_sheet As Object
Dim mdbk As Database
Dim new_value As String
Dim row, cell, i As Integer
Dim cell1, cell2, cell3, cell4, cell5 As String
Screen.MousePointer = vbHourglass
DoEvents
Set excel_app = CreateObject("Excel.Application")
excel_app.Workbooks.Open FileName:=txtExcelFile.Text
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
Set mdbk = OpenDatabase(txtAccessFile.Text)
row = 1
a: Do
For cell = 1 To 5
new_value = Trim$(excel_sheet.Cells(row, cell))
If cell = 1 Then
cell1 = new_value
End If
If cell = 2 Then
cell2 = new_value
End If
If cell = 3 Then
cell3 = new_value
End If
If cell = 4 Then
cell4 = new_value
End If
If cell = 5 Then
cell5 = new_value
End If
Next cell
If cell1 = "" And cell2 = "" And cell3 = "" And cell4 = "" And cell5 = "" Then
row = row + 1
If row = 1000 Then
Exit Do
End If
GoTo a
Else
mdbk.Execute "INSERT INTO dianhua(主叫号码,被叫号码,开始时间,通话时间（秒）,金额（元）) VALUES ('" & CStr(cell1) & "','" & CStr(cell2) & "','" & CStr(cell3) & "','" & CStr(cell4) & "','" & CStr(cell5) & "')"
row = row + 1
End If
Loop
mdbk.Close
Set mdbk = Nothing
excel_app.ActiveWorkbook.Close False
excel_app.Quit
Set excel_sheet = Nothing
Set excel_app = Nothing
Screen.MousePointer = vbDefault
MsgBox "Copied " & Format$(row - 1) & " values."
Command3.Enabled = True: Command5.Enabled = True
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Set cg = sjklj()
cgksql = "select * from dianhua"
cgk.Open cgksql, cg
While Not cgk.EOF
zd2 = cgk.Fields(2).Value
zd1 = cgk.Fields(1).Value
If Mid(zd1, 1, 2) = "00" Then
If Val(cgk.Fields(3).Value) < 60 Then
Set cgup = sjklj()
cgkupsql = "update dianhua set 金额（元）='" + CStr(1) + "' where 开始时间='" + CStr(zd2) + "'"
cgkup.Open cgkupsql, cgup
End If
End If
cgk.MoveNext
Wend
cgk.Close
Set cg = sjklj()
cgksql = "select * from dianhua"
cgk.Open cgksql, cg
While Not cgk.EOF
zd1 = cgk.Fields(1).Value
zd2 = cgk.Fields(2).Value
zd3 = cgk.Fields(3).Value
zd4 = cgk.Fields(4).Value
If Mid(zd1, 1, 2) = "00" Then
If zd3 < 60 Then
Set cgup = sjklj()
cgkupsql = "update dianhua set 金额（元）='" + CStr(1) + "' where 开始时间='" + CStr(zd2) + "'"
cgkup.Open cgkupsql, cgup
Else
thsj = Val(zd3) Mod 60
If thsj > 0 Then
thsjxs = Int(Val(zd3) / 60)
thsjxs = thsjxs + 1
zd4 = Val(zd4) + thsjxs * 0.7
Set cgup = sjklj()
cgkupsql = "update dianhua set 金额（元）='" + CStr(zd4) + "' where 开始时间='" + CStr(zd2) + "'"
cgkup.Open cgkupsql, cgup
Else
thsjxs = zd4 + Int(Val(zd3) / 60) * 0.7
Set cgup = sjklj()
cgkupsql = "update dianhua set 金额（元）='" + CStr(thsjxs) + "' where 开始时间='" + CStr(zd2) + "'"
cgkup.Open cgkupsql, cgup
End If
End If
End If
cgk.MoveNext
Wend
cgk.Close
Set cg = sjklj()
cgksql = "select * from dianhua"
cgk.Open cgksql, cg
If cgk.EOF Then
msn = MsgBox("对不起，目前库为空！", vbQuestion, "系统提示！")
cgk.Close
Else
DataGrid1.Visible = True
Adodc1.CommandType = adCmdText
Adodc1.ConnectionString = cg
Adodc1.RecordSource = cgksql
Set DataGrid1.DataSource = Adodc1
Adodc1.Refresh
cgk.Close
End If
Command3.Enabled = False
End Sub
Private Sub Command4_Click()
Set cg = sjklj()
cgksql = "select * from dianhua"
cgk.Open cgksql, cg
Open App.Path + "\XlsToMdb.txt" For Output As #1
Write #1, "主叫号码", Space(10), "被叫号码", Space(10), "开始时间", Space(10), "通话时间（秒）", Space(6), "金额（元）"
While Not cgk.EOF
zd0 = cgk.Fields(0).Value
zd1 = cgk.Fields(1).Value
zd2 = cgk.Fields(2).Value
zd3 = cgk.Fields(3).Value
zd4 = cgk.Fields(4).Value
jehz = jehz + zd4
Write #1, zd0 + Space(10) + zd1 + Space(10) + zd2 + Space(12) + zd3 + Space(22) + "0" + CStr(zd4) + "元"
cgk.MoveNext
Wend
cgk.Close
Write #1, "总计通话金额为" + Space(8) + CStr(jehz) + "元"
Close #1
msn = MsgBox("你的数据已成功的导出，请你查看你安装目录下的XlsToMdb.txt记事本文件", vbOKOnly, "系统提示")
End Sub
Private Sub Command5_Click()
Set cg = sjklj()
cgksql = "delete * from dianhua"
cgk.Open cgksql, cg
Command5.Enabled = False
DataGrid1.Visible = False
msn = MsgBox("您的数据库已成功清除！", vbOKOnly, "系统提示")
End Sub

Private Sub Command6_Click()
Set cg = sjklj()
cgksql = "select * from dianhua"
cgk.Open cgksql, cg
Adodc1.CommandType = adCmdText
Adodc1.ConnectionString = cg
Adodc1.RecordSource = cgksql
cgk.Close
Set DataReport1.DataSource = Adodc1
DataReport1.Show
End Sub

Private Sub Form_Load()
Dim file_path As String
file_path = App.Path
If Right$(file_path, 1) <> "\" Then
file_path = file_path & "\"
End If
txtExcelFile.Text = file_path & "XlsToMdb.xls"
txtAccessFile.Text = file_path & "XlsToMdb.mdb"
End Sub
这是我做的一个小程序，希望对你有帮助，里面的控件，自己加！

[jtkkjtkk]

http://blog.csdn.net/litp/archive/2004/09/07/96494.aspx

[Andy__Huang]

打開Excel的一個表
select * from OPENROWSET('MICROSOFT.JET.OLEDB.4.0'
,'Excel 5.0;HDR=YES;DATABASE=e:\test.xls',sheet1$)


所以导入Access和 MSSQL数据库
select * into 目標表 from OPENROWSET('MICROSOFT.JET.OLEDB.4.0'
,'Excel 5.0;HDR=YES;DATABASE=e:\test.xls',sheet1$)

不過excel要有列名