Dim filename,sheetname Dim xlApp Dim xlWorkbook Dim xlWorksheet Dim i,constr,con,rst,iRowCount filename= '此处填写要导入excel的完整文件路径 If filename="" Then Msgbox "还没有选择需要导入的文件!" Else sheetname = '此处填写的是excel表重要导入的sheet名字 Dim e '确认是否更新 e=Msgbox("你即将导入'"& filename &"'的数据到 ERS点 数据表中,请再次确认!",vbOKCancel) If e=vbOk Then constr="Provider=SQLOLEDB.1;Password=pwd;Persist Security Info=True;User ID=userName;Initial Catalog=databaseName;Data Source=127.0.0.1" '在wincc里面的时候要在链接ip后面加上 /wincc Set con = CreateObject("ADODB.Connection") con.ConnectionString = constr con.Open If Con.State = 0 Then '判断数据库连接是否成功 ' MsgBox "连接数据库失败" Else MsgBox "连接数据库成功" End If Set xlApp=CreateObject("Excel.Application") Set xlWorkBook=xlApp.Workbooks.Open(filename) xlApp.Visible=True Set xlWorksheet=xlWorkBook.WorkSheets(sheetname) xlWorkBook.WorkSheets(sheetname).Activate iRowCount = xlWorksheet.usedRange.Rows.Count '获取sheet中有内容的Rowcount行数 If iRowCount<=1 Then MsgBOX "表中不存在数据,请检查~" Else '此处我用的是直接请空数据库 con.Execute "truncate table initial_coordinates" Dim X,Y,Z,ID,point_name,X1,Y1,Z1 '读取excel表中数据并且写入到数据库中 For i=2 To iRowCount ID=i-1 X=xlWorksheet.Range("B" & i).Value Y=xlWorksheet.Range("C" & i).Value Z=xlWorksheet.Range("D" & i).Value point_name=xlWorksheet.Range("A" & i).Value X1=xlWorksheet.Range("E" & i).Value Y1=xlWorksheet.Range("F" & i).Value Z1=xlWorksheet.Range("G" & i).Value con.Execute "insert into initial_coordinates values(N'"& ID &"',N'"& point_name &"',"& X &","& Y &","& Z &","& X1 &","& Y1 &","& Z1 &")" Next MsgBox "数据已经导入成功!" If con.state Then con.Close '关闭数据连接 Set xlWorkBook=Nothing Set xlApp=Nothing End If Else End if End if