VB6.0如何实现将excel数据导入mssql数据库中
我在VB6.0中的模块中加入了连接sql的语句,连接已经没有问题了,做登录系统和将sql的数据导入到excel中也没有问题,但就是不知如何实现将excel数据导入mssq...
我在VB6.0中的模块中加入了连接sql的语句,连接已经没有问题了,做登录系统和将sql的数据导入到excel中也没有问题,但就是不知如何实现将excel数据导入mssql数据库中,批量的导入,请高手指教下,谢谢了先!
Public SQL As String
Public rs As ADODB.Recordset
Public ConnStr As String
Public Conn As ADODB.Connection
Public Function Selectsql(SQL As String) As ADODB.Recordset
'Dim ConnStr As String '已公共申明
'Dim Conn As ADODB.Connection
'Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Set Conn = New ADODB.Connection
On Error GoTo MyErr:
ConnStr = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=sa;Password=******;Initial Catalog=wzglxt;Data Source=127.0.0.1" '这是连接SQL数据库的语句
Conn.Open ConnStr
rs.CursorLocation = adUseClient
rs.Open Trim$(SQL), Conn, adOpenDynamic, adLockOptimistic
Set Selectsql = rs
Exit Function
MyErr:
Set rs = Nothing
Set Conn = Nothing
MsgBox "系统出错,请联系开发人员怀哥,E-mail:slyjpsh@qq.com", vbInformation, "系统提示"
End Function
执行
Dim strSQL As String
CommonDialog1.Filter = "电子表格文件(.xls)|*.xls"
CommonDialog1.DialogTitle = "请选择要导入的文件"
CommonDialog1.ShowOpen
SQL = "INSERT INTO Family SELECT * FROM OpenRowSet('microsoft.jet.oledb.4.0','Excel 14.0;HDR=Yes;database=" & CommonDialog1.FileName & " ;','select * from [Sheet1$] ')"
Set rs = Selectsql(SQL)
Conn.Execute SQL, , adExecuteNoRecords
Conn.Close
Set Conn = Nothing
MsgBox "导入成功", vbExclamation + vbOKOnly
Exit Sub 展开
Public SQL As String
Public rs As ADODB.Recordset
Public ConnStr As String
Public Conn As ADODB.Connection
Public Function Selectsql(SQL As String) As ADODB.Recordset
'Dim ConnStr As String '已公共申明
'Dim Conn As ADODB.Connection
'Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Set Conn = New ADODB.Connection
On Error GoTo MyErr:
ConnStr = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=sa;Password=******;Initial Catalog=wzglxt;Data Source=127.0.0.1" '这是连接SQL数据库的语句
Conn.Open ConnStr
rs.CursorLocation = adUseClient
rs.Open Trim$(SQL), Conn, adOpenDynamic, adLockOptimistic
Set Selectsql = rs
Exit Function
MyErr:
Set rs = Nothing
Set Conn = Nothing
MsgBox "系统出错,请联系开发人员怀哥,E-mail:slyjpsh@qq.com", vbInformation, "系统提示"
End Function
执行
Dim strSQL As String
CommonDialog1.Filter = "电子表格文件(.xls)|*.xls"
CommonDialog1.DialogTitle = "请选择要导入的文件"
CommonDialog1.ShowOpen
SQL = "INSERT INTO Family SELECT * FROM OpenRowSet('microsoft.jet.oledb.4.0','Excel 14.0;HDR=Yes;database=" & CommonDialog1.FileName & " ;','select * from [Sheet1$] ')"
Set rs = Selectsql(SQL)
Conn.Execute SQL, , adExecuteNoRecords
Conn.Close
Set Conn = Nothing
MsgBox "导入成功", vbExclamation + vbOKOnly
Exit Sub 展开
1个回答
展开全部
这里是我用的代码,估计对你有用:
'On Error Resume Next
Dim fileadd As String
CommonDialog1.ShowOpen
CommonDialog1.Filter = "xls文件(*.xls)|*.xls" '选择你要的文件
fileadd = CommonDialog1.FileName
If fileadd = "" Then Exit Sub
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False ' = True '设置EXCEL对象可见(或不可见)
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
For R = 1 To 99999 '行循环
If LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) <> "" Then
sybw.Adodc3.Refresh
sybw.Adodc3.Recordset.Find "ShiGongBuWei_Name='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) & "'"
If sybw.Adodc3.Recordset.EOF Then
sybw.Adodc3.Recordset.AddNew
sybw.Adodc3.Recordset!ShiGongBuWei_Name = LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1)))
sybw.Adodc3.Recordset!FenXiangGongCheng_ID = bb
sybw.Adodc3.Recordset.Update
sybw.Adodc3.Refresh
' Call log(MM_Users_NameTrue, "增加了施工部位", MM_Companys_ID)
Else
' MsgBox " 施工部位重复! ", vbOKOnly, "用户信息"
End If
Else
R = 99999 + 1
End If
Next R
xlApp.DisplayAlerts = False '不进行安全提示 '
Set xlSheet = Nothing '
Set xlBook = Nothing '
xlApp.Quit '
Set xlApp = Nothing
'On Error Resume Next
Dim fileadd As String
CommonDialog1.ShowOpen
CommonDialog1.Filter = "xls文件(*.xls)|*.xls" '选择你要的文件
fileadd = CommonDialog1.FileName
If fileadd = "" Then Exit Sub
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False ' = True '设置EXCEL对象可见(或不可见)
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
For R = 1 To 99999 '行循环
If LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) <> "" Then
sybw.Adodc3.Refresh
sybw.Adodc3.Recordset.Find "ShiGongBuWei_Name='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) & "'"
If sybw.Adodc3.Recordset.EOF Then
sybw.Adodc3.Recordset.AddNew
sybw.Adodc3.Recordset!ShiGongBuWei_Name = LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1)))
sybw.Adodc3.Recordset!FenXiangGongCheng_ID = bb
sybw.Adodc3.Recordset.Update
sybw.Adodc3.Refresh
' Call log(MM_Users_NameTrue, "增加了施工部位", MM_Companys_ID)
Else
' MsgBox " 施工部位重复! ", vbOKOnly, "用户信息"
End If
Else
R = 99999 + 1
End If
Next R
xlApp.DisplayAlerts = False '不进行安全提示 '
Set xlSheet = Nothing '
Set xlBook = Nothing '
xlApp.Quit '
Set xlApp = Nothing
更多追问追答
追问
哥们,你这是将excel的数据批量导入到sql中吗?怎么没有sql数据库对应的表名?如SQL = "INSERT INTO Family SELECT * FROM OpenRowSet('**** ')"
追答
重新 给你代码:
Private Sub Command1_Click()
Dim fileadd As String
CommonDialog1.ShowOpen
CommonDialog1.Filter = "xls文件(*.xls)|*.xls" '选择你要的文件
fileadd = CommonDialog1.FileName
If fileadd = "" Then Exit Sub
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False ' = True '设置EXCEL对象可见(或不可见)
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
For R = 1 To 99999 '行循环
If LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) "" Then
Call Dosql("INSERT INTO CB_JiXieFeiYong (danwei_name) VALUES (" & LTrim(RTrim(xlBook.Worksheets(1).Cells(R, 1))) & ")")
Else
R = 99999 + 1
End If
Next R
xlApp.DisplayAlerts = False '不进行安全提示 '
Set xlSheet = Nothing '
Set xlBook = Nothing '
xlApp.Quit '
Set xlApp = Nothing
Unload Me
End Sub
Private Sub Dosql(ByVal tn As String) '执行SQL语句
Dim sql As String
Set conn = New ADODB.Connection
conn.ConnectionString = condstr
conn.Open
conn.Execute tn
conn.Close
End Sub
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询
广告 您可能关注的内容 |