【VBA】 通过VBA脚本将EXCEL的数据导入 ORACLE

作者：lianghc

描述：最近在使用infamatica 将excel  的数据导入oracle时，遇到意外终止错误，无法将数据导入。于是采用VBA将数据导入数据库，是办公人员一键同步excel的数据导数据库中，这种做法的前提是提供标准的模板。下面是解决问题过程中收集的连接数据库的方法，整理一下供大家参考。

1、引用法

引用ADO相关组件：打开VBA编辑器，在菜单中点选“工具”--》“引用”。确保“Microsoft ActiviteX Data Objects 2.8 Library”和“Microsoft ActiviteX Data ObjectS Recordset 2.8 Library”被勾选上。引用后再声明:

Dim cnn As New Connection '声明链接对象
Dim rst As New Recordset '声明记录集对象

例子：

Dim cnn As New Connection 
Dim rst As New Recordset 
cnn.Open "Provider=msdaora.1;Data Source=dl580;User Id=emssxjk;Password=emssxjk;" 
OraOpen = True '成功执行后，数据库即被打开 

sqls = "select count(*) from tb_evt_dlv where mail_num='" & emsid & "'" 
Set rst = cnn.Execute(sqls) 
If rst(0) > 0 Then 
sqls = "select b.zj_code,b.zj_mc,b.jgfl,b.city,b.ssxs from tb_evt_dlv a, tb_jg b " 
sqls = sqls & "where a.dlv_bureau_org_code = b.zj_code and a.mail_num='" & emsid & "' and rownum=1" 
Set rst = cnn.Execute(sqls) 
sqls = "CopyFromRecordset" 
'maxrow = Sheets(qfxx).[A65536].End(xlUp).Row 
'If maxrow > 1 Then Sheets(qfxx).Range("a2:H" & maxrow).ClearContents 
Cells(row1, pos_sav).CopyFromRecordset rst 
Else 
sqls = "select b.zj_code,b.zj_mc,b.jgfl,b.city,b.ssxs from tb_evt_mail_clct a, tb_jg b " 
sqls = sqls & "where a.clct_bureau_org_code = b.zj_code and a.mail_num='" & emsid & "' and rownum=1" 
Set rst = cnn.Execute(sqls) 
sqls = "CopyFromRecordset" 
'maxrow = Sheets(qfxx).[A65536].End(xlUp).Row 
'If maxrow > 1 Then Sheets(qfxx).Range("a2:H" & maxrow).ClearContents 
Cells(row1, pos_sav + 5).CopyFromRecordset rst 
End If 

2、创建法

不需要引用ADO相关组件，直接使用CreateObject函数创建ADO对象，即：
Set cnn = CreateObject("ADODB.connection") '创建ado对象
Set rst = CreateObject("ADODB.recordset") '创建记录集
下面是例程（和上面例程类似，前半部分不同，后面的相同）：

Dim cnn As Object, rst As Object 

Set cnn = CreateObject("ADODB.Connection") 
Set rst = CreateObject("ADODB.Recordset") 
cnn.Open "Provider=msdaora.1;Data Source=dl580;User Id=emssxjk;Password=emssxjk;" 
OraOpen = True '成功执行后，数据库即被打开 

其它组件的使用也和这个差不多，建议用创建法，这样就不用管“引用”中的设置了，例如：

Dim dic As Object '直接创建不需要引用
Set dic = CreateObject("scripting.dictionary") '创建字典对象


Dim fso as Object '直接创建不需要引用

Set fso = CreateObject("Scripting.FileSystemObject") '创建文件对象模型

上面内容引自：http://blog.csdn.net/iamlaosong/article/details/45096059  （这个博客写的不错）

我的示例：

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
    
Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long

Public Function GetGUID() As String
    '(c) 2000 Gus Molina
    
    Dim udtGUID As GUID
    
    If (CoCreateGuid(udtGUID) = 0) Then
    
        GetGUID = _
        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
    End If

End Function
’前面的是生成唯一标识GUID的代码。
Sub Table_to_Oracle()

    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    Dim datasource As String
    Dim userid As String
    Dim password As String
    
    On Error GoTo Err_Handle  '如果遇到错误就跳转到错误处，并提示错误
        
        ThisWorkbook.Sheets("1").Select '将连接信息存在表格里
        datasource = ""
        userid = ""
        password = ""
     
        cnn.Open "Provider=msdaora;Data Source=" & datasource & ";User Id=" & userid & ";Password=" & password & ";" '打开数据库连接
            
        
                C_TEST= GetGUID  '插入32位的GUID

        If deleteflag Then
            cnn.Execute ("delete from TOP_REPAYPLAN where C_PROJECTCODE= " & C_PROJECTCODE)
            deleteflag = False
         End If
                
         insert_sql = "insert into TABLE_TEST(C_TEST) "
         value_sql = " values(" & C_TEST & ")"
                
         Set rst = cnn.Execute(insert_sql & value_sql)
           
     
        cnn.Close
        
        MsgBox "成功导入！", vbInformation, "导入信息"
        Exit Sub
Err_Handle:
    MsgBox Err.Description, vbExclamation, "异常信息"

End Sub

Sub readme()
   MsgBox "您好，数据导入过程中如果有出错信息，请联系开发人员。", vbInformation, "友情提示"
End Sub

'网上收集的另一段比较好的代码：

Public Sub ConOra()
On Error GoTo ErrMsg:
Dim ConnDB As ADODB.Connection
Set ConnDB = New ADODB.Connection
Dim ConnStr As String
Dim DBRst As ADODB.Recordset
Set DBRst = New ADODB.Recordset
Dim SQLRst As String
Dim OraOpen As Boolean
OraOpen = False
OraID = "orcl" 'Oracle数据库的相关配置
OraUsr = "scott"
OraPwd = "tiger"
ConnStr = "Provider = MSDAORA.1;Password=" & OraPwd & _
";User ID=" & OraUsr & _
";Data Source=" & OraID & _
";Persist Security Info=True"
ConnDB.CursorLocation = adUseServer
ConnDB.Open ConnStr
OraOpen = True '成功执行后，数据库即被打开
'MsgBox "Connect to the oracle database Successful!", vbInformation, "Connect Successful"
DBRst.ActiveConnection = ConnDB
DBRst.CursorLocation = adUseServer
DBRst.LockType = adLockBatchOptimistic
SQLRst = "Select * From TB_USER"
DBRst.Open SQLRst, ConnDB, adOpenStatic, adLockBatchOptimistic

For Each x In DBRst.Fields
 x.Name
 Next
 Do Until DBRst.EOF
   
   For Each i In DBRst.Fields
      Response.Write (i.Value)
   Next
    DBRst.MoveNext
    
  Loop
  DBRst.Close
DBRst.MoveFirst
Exit Sub
ErrMsg:
OraOpen = False
MsgBox "Connect to the oracle database fail ,please check!", vbCritical, "Connect fail!"
End Sub