Excel中用VBA链接Oracle实现位置随意标题
我用的是Oracle 11g + Microsoft Office 2010 旗舰版首先要添加引用类库：
Microsoft ActiveX Data Objects Recordset 6.0（或者2.8）Library
Microsoft Activex Data Objects 6.1（或者2.8） Library
链接Oracle的字符串有三种，而我试验了几次两种，一种是odbc，另一种是ado方式
这两种链接方式如下：
odbc：
"DSN=orcl;UID=scott;PWD=tiger;DBQ=ORCL;DBA=W;APA=T;EXC=F;
FEN=T;QTO=T;FRC=10;FDL=10;LOB=T;RST=T;BTD=F;BNF=F;BAM=IfAllSuccessful;
NUM=NLS;DPM=F;MTS=T;MDI=F;CSR=F;FWC=F;FBS=64000;TLO=O;MLD=0;ODA=F;"
ado：
"Provider = OraOLEDB.Oracle;Persist Security Info=true;User> 其中odbc只能实现链接本机数据库，不能远程，而ado方式可以实现远程连接，只需把host后面的ip改成目标地址即可。
做了一个活动标题的excel vba例子，所谓活动标题，是位置比较随意，可以互换位置，但中间不能有空的单元格，如果表头中有“序列”的话，可以自动编号。下面就贴上代码
VBA代码
[*]Option Explicit
[*]Public Const DATA_START_ROW As Byte = 4 '数据起始位置
[*]Public fieldsCount As Integer
[*]Public fieldsZH() As String '中文名称 表头
[*]Public fieldsEN() As String '英文名称，数据库字段
[*]Public fieldsType() As String '字段类型
[*]
[*]'初始化字段值
[*]Sub initFields()
[*] Dim i As Integer
[*] ThisWorkbook.Sheets(1).Activate
[*] With Range("A1").CurrentRegion
[*] fieldsCount = .Rows.Count
[*] End With
[*]
[*] ReDim fieldsZH(fieldsCount - 1)
[*] ReDim fieldsEN(fieldsCount - 1)
[*] ReDim fieldsType(fieldsCount - 1)
[*]
[*] For i = 0 To fieldsCount - 1
[*] fieldsZH(i) = Cells(i + 1, 1)
[*] fieldsEN(i) = Cells(i + 1, 2)
[*] fieldsType(i) = Cells(i + 1, 3)
[*] Next
[*]End Sub
[*]
[*]Option Explicit
[*]
[*]'定义链接属性
[*]Dim conn As ADODB.Connection '##################################################
[*]Dim rs As ADODB.Recordset '#######################################
[*]Dim OraID As String
[*]Dim OraUsr As String
[*]Dim oraPwd As String
[*]Dim serIP As String
[*]Dim sqlStr As String
[*]
[*]'初始化链接属性
[*]Sub InitConnect()
[*] On Error GoTo ConnectingError
[*] Set conn = New ADODB.Connection
[*] Set rs = New ADODB.Recordset
[*] OraID = "orcl" 'Oracle数据库的相关配置
[*] OraUsr = "scott" '用户名
[*] oraPwd = "tiger" '登录密码
[*] serIP = "127.0.0.1" '数据库ip地址和数据困服务器名
[*] conn.ConnectionString = "Provider = OraOLEDB.Oracle.1;" & _
[*] "Password=" & oraPwd & ";User ID=" & OraUsr & _
[*] ";Data Source=(DESCRIPTION=(ADDRESS=(PROTOCOL=TCP)" & _
[*] "(HOST=" & serIP & ")(PORT=1521))" & _
[*] "(CONNECT_DATA=(SERVICE_NAME=" & OraID & ")))"
[*] 'MsgBox conn.ConnectionString
[*] conn.Open
[*] rs.ActiveConnection = conn
[*] Exit Sub
[*]ConnectingError:
[*] MsgBox "无法连接数据库，请检查数据库服务配置"
[*] Exit Sub
[*]End Sub
[*]
[*]'从Excel同步到Oracle
[*]Sub ExcelToOracle()
[*]
[*]End Sub
[*]
[*]'关闭连接
[*]Sub CloseConnect()
[*] On Error Resume Next
[*] If Not IsEmpty(rs) Then
[*] rs.Close
[*] End If
[*] If Not IsEmpty(conn) Then
[*] conn.Close
[*] End If
[*]End Sub
[*]
[*]'从Oracle同步到Excel
[*]Sub OracleToExcel()
[*] InitConnect '初始化链接
[*] initFields'初始化字段
[*] Dim i As Integer
[*] Dim j As Integer
[*] Dim k As Integer
[*] Dim excelTitleSeq() As Integer '存储表头对应的数据库字段所在位置
[*] Dim flag As Boolean '循环跳出标识
[*] Dim idSeq As Integer ' 表头中“序列”的下标
[*]
[*] ThisWorkbook.Sheets(2).Activate
[*] sqlStr = "select * from empinfo where newdata=1"
[*] rs.Open Source:=sqlStr, LockType:=adLockBatchOptimistic
[*]
[*] ReDim excelTitleSeq(rs.Fields.Count - 1)
[*] For i = 0 To rs.Fields.Count - 1
[*] excelTitleSeq(i) = -1
[*] Next
[*]
[*]
[*]
[*] '----------------------新算法, 序列位置随意
[*] For i = 0 To Cells(DATA_START_ROW - 1, 1).CurrentRegion.Columns.Count - 1 '循环匹配表头
[*] If Cells(1, DATA_START_ROW - 1).Value = "序列" Then
[*] idSeq = i + 1
[*] End If
[*] flag = False
[*] For j = 0 To fieldsCount - 1 '依次找到对应的数据库字段的下标
[*] If Trim(Cells(DATA_START_ROW - 1, i + 1)) = Trim(fieldsZH(j)) Then
[*] For k = 0 To rs.Fields.Count - 1 '从数据库字段中查找这个对应值
[*] If UCase(Trim(fieldsEN(j))) = UCase(Trim(rs.Fields(k).Name)) Then
[*] excelTitleSeq(i) = k
[*] flag = True
[*] Exit For
[*] End If
[*] Next
[*] End If
[*] If flag Then
[*] Exit For
[*] End If
[*] Next
[*] Next
[*]
[*]
[*]
[*]
[*] '给表格赋值
[*] i = DATA_START_ROW
[*] Do Until rs.EOF
[*] For j = 0 To rs.Fields.Count - 1
[*] If idSeq0 Then '判断是否有“序列”
[*] Cells(i, idSeq).Value = i - DATA_START_ROW + 1
[*] End If
[*]
[*] If excelTitleSeq(j)-1 Then
[*] Cells(i, j + 1).Value = rs.Fields(excelTitleSeq(j)).Value
[*] End If
[*] Next
[*] i = i + 1
[*] rs.MoveNext
[*] Loop
[*] CloseConnect
[*]End Sub
sql语句
[*]--人员基本信息表
[*]create table empinfo(
[*] email varchar2(50), --邮箱
[*] eno varchar2(12) unique, --人员编号
[*] ename varchar2(20) not null, --人员姓名
[*] eid varchar2(20) unique, --身份证号码
[*] cardno varchar2(6) unique, --卡号
[*] status varchar2(20), --状态
[*] org varchar2(50), --人员组织
[*] egroup varchar2(50), --组别 由group改-
[*] groupno varchar2(10), --组号 由组别截取第一位
[*] formation varchar2(25), --编制
[*] sex varchar2(10), --性别
[*] birthday varchar2(20), --出生日期
[*] address varchar2(100), --家庭住址
[*] drivetime varchar2(20), --车程
[*] graduate varchar2(50), --毕业院校
[*] major varchar2(50), --专业
[*] job varchar2(50), --职务
[*] elevel varchar2(20), --等级 由level改
[*] eresume varchar2(10), --简历 是否有 由resume改
[*] erole varchar2(50), --角色 由role改
[*] tutor varchar2(20), --导师
[*] phone varchar2(20), --电话
[*] tel varchar2(20), --座机
[*] education varchar2(20), --学历
[*] leveltime varchar2(20), --等级时间
[*] graduateyear varchar2(10), --毕业年份
[*] interntime varchar2(20), --见习时间
[*] comtime varchar2(20), --入司时间
[*] deptime varchar2(20), --入部门时间
[*] depyear varchar2(10), --入部门年度
[*] beforeinfo varchar2(500), --入部门前情况
[*] leavetime varchar2(20), --离职时间
[*] workinfo varchar2(500), --工作经历
[*] projectexpr varchar2(500), --卫生政务项目经历
[*] tecinfo varchar2(50), --技术认证
[*] certificate varchar2(10), --证书
[*] marriage varchar2(10), --婚姻 已婚 未婚 离异
[*] childyear varchar2(10), --小孩年份
[*] im1 varchar2(20), --及时通讯工具1
[*] im2 varchar2(20), --及时通讯工具2
[*] linkman varchar2(20), --紧急联系人
[*] linkmanphone varchar2(20), --紧急联系人电话
[*] tecdirection varchar2(50), --推荐技术方向
[*] homephone varchar2(20), --家庭电话
[*] comments varchar2(500), --备注
[*] newdata varchar2(1)--最新数据标识
[*]);
附件中，只实现了从Oracle导出到excel，另一个按钮功能没有实现
页:
[1]