2024年9月14日发(作者：)
excel
中
vba
技术应用
[示例04-01]增加工作表(Add方法)
SubAddWorksheet()
MsgBox"在当前工作簿中添加一个工作表"
MsgBox"在当前工作簿中的工作表sheet2之前添加一个工作表"
ore:=Worksheets("sheet2")
MsgBox"在当前工作簿中的工作表sheet2之后添加一个工作表"
er:=Worksheets("sheet2")
MsgBox"在当前工作簿中添加3个工作表"
nt:=3
EndSub
示例说明：Add方法带有4个可选的参数，其中参数Before和参数After指定所增加的工作表的位置，但两个
参数只能选一；参数Count用来指定增加的工作表数目。
--------------------------------------------------------------------------------
[示例04-02]复制工作表(Copy方法)
SubCopyWorksheet()
MsgBox"在当前工作簿中复制工作表sheet1并将所复制的工作表放在工作表sheet2之前"
Worksheets("sheet1").CopyBefore:=Worksheets("sheet2")
MsgBox"在当前工作簿中复制工作表sheet2并将所复制的工作表放在工作表sheet3之后"
Worksheets("sheet2").CopyAfter:=Worksheets("sheet3")
EndSub
示例说明：Copy方法带有2个可选的参数，即参数Before和参数After，在使用时两个参数只参选一。
--------------------------------------------------------------------------------
[示例04-03]移动工作表(Move方法)
SubMoveWorksheet()
MsgBox"在当前工作簿中将工作表sheet3移至工作表sheet2之前"
Worksheets("sheet3").MoveBefore:=Worksheets("sheet2")
MsgBox"在当前工作簿中将工作表sheet1移至最后"
Worksheets("sheet1").MoveAfter:=Worksheets()
EndSub
示例说明：Move方法与Copy方法的参数相同，作用也一样。
--------------------------------------------------------------------------------
[示例04-04]隐藏和显示工作表(Visible属性)
[示例04-04-01]
SubtestHide()
MsgBox"第一次隐藏工作表sheet1"
Worksheets("sheet1").Visible=False
MsgBox"显示工作表sheet1"
Worksheets("sheet1").Visible=True
MsgBox"第二次隐藏工作表sheet1"
Worksheets("sheet1").Visible=xlSheetHidden
MsgBox"显示工作表sheet1"
Worksheets("sheet1").Visible=True
MsgBox"第三次隐藏工作表sheet1"
Worksheets("sheet1").Visible=xlSheetHidden
MsgBox"显示工作表sheet1"
Worksheets("sheet1").Visible=xlSheetVisible
MsgBox"第四隐藏工作表sheet1"
Worksheets("sheet1").Visible=xlSheetVeryHidden
MsgBox"显示工作表sheet1"
Worksheets("sheet1").Visible=True
MsgBox"第五隐藏工作表sheet1"
Worksheets("sheet1").Visible=xlSheetVeryHidden
MsgBox"显示工作表sheet1"
Worksheets("sheet1").Visible=xlSheetVisible
EndSub
示例说明：本示例演示了隐藏和显示工作表的各种情形。其中，使用xlSheetVeryHidden常量来隐藏工作表，
将不能通过选择工作表菜单栏中的“格式”——“工作表”——“取消隐藏”命令来取消隐藏。
--------------------------------------------------------------------------------
[示例04-04-02]
SubShowAllSheets()
MsgBox"使当前工作簿中的所有工作表都显示(即将隐藏的工作表也显示)"
DimwsAsWorksheet
ForEachwsInSheets
e=True
Nextws
EndSub
--------------------------------------------------------------------------------
[示例04-05]获取工作表数(Count属性)
[示例04-05-01]
SubWorksheetNum()
DimiAsLong
i=
MsgBox"当前工作簿的工作表数为："&Chr(10)&i
EndSub
--------------------------------------------------------------------------------
[示例04-05-02]
SubWorksheetNum()
DimiAsLong
i=
MsgBox"当前工作簿的工作表数为："&Chr(10)&i
EndSub
示例说明：在一个包含图表工作表的工作簿中运行上述两段代码，将会得出不同的结果，原因是对于Sheets集
合来讲，工作表包含图表工作表。应注意Worksheets集合与Sheets集合的区别，下同。
--------------------------------------------------------------------------------
[示例04-06]获取或设置工作表名称(Name属性)
[示例04-06-01]
SubNameWorksheet()
DimsNameAsString,sChangeNameAsString
sName=Worksheets(2).Name
MsgBox"当前工作簿中第2个工作表的名字为："&sName
sChangeName="我的工作表"
MsgBox"将当前工作簿中的第3个工作表名改为："&sChangeName
Worksheets(3).Name=sChangeName
EndSub
示例说明：使用Name属性可以获取指定工作表的名称，也可以设置工作表的名称。
--------------------------------------------------------------------------------
[示例04-06-02]重命名工作表
SubReNameSheet()
DimxStrAsString
Retry:
xStr=InputBox("请输入工作表的新名称:"_
,"重命名工作表",)
IfxStr=""ThenExitSub
OnErrorResumeNext
=xStr
<>0Then
&""&ption
GoToRetry
EndIf
OnErrorGoTo0
'.........
EndSub
[示例04-07]激活/选择工作表(Activate方法和Select方法)
[示例04-07-01]
SubSelectWorksheet()
MsgBox"激活当前工作簿中的工作表sheet2"
Worksheets("sheet2").Activate
MsgBox"激活当前工作簿中的工作表sheet3"
Worksheets("sheet3").Select
MsgBox"同时选择工作簿中的工作表sheet2和sheet3"
Worksheets(Array("sheet2","sheet3")).Select
EndSub
示例说明：Activate方法只能激活一个工作表，而Select方法可以同时选择多个工作表。
--------------------------------------------------------------------------------
[示例04-07-02]
SubSelectManySheet()
MsgBox"选取第一个和第三个工作表."
Worksheets(1).Select
Worksheets(3).SelectFalse
EndSub
--------------------------------------------------------------------------------
[示例04-08]获取当前工作表的索引号(Index属性)
SubGetSheetIndex()
DimiAsLong
i=
MsgBox"您正使用的工作表索引号为"&i
EndSub
--------------------------------------------------------------------------------
[示例04-09]选取前一个工作表(Previous属性)
SubPreviousSheet()
<>1Then
MsgBox"选取当前工作簿中当前工作表的前一个工作表"
te
Else
MsgBox"已到第一个工作表"
EndIf
EndSub
示例说明：如果当前工作表是第一个工作表，则使用Previous属性会出错。
--------------------------------------------------------------------------------
[示例04-10]选取下一个工作表(Next属性)
SubNextSheet()
<>hen
MsgBox"选取当前工作簿中当前工作表的下一个工作表"
te
Else
MsgBox“已到最后一个工作表”
EndIf
EndSub
示例说明：如果当前工作表是最后一个工作表，则使用Next属性会出错。
--------------------------------------------------------------------------------
[示例04-11]工作表行和列的操作
[示例04-11-01]隐藏行
SubHideRow()
DimiRowAsLong
MsgBox"隐藏当前单元格所在的行"
iRow=
(iRow).Hidden=True
MsgBox"取消隐藏"
(iRow).Hidden=False
EndSub
--------------------------------------------------------------------------------
[示例04-11-02]隐藏列
SubHideColumn()
DimiColumnAsLong
MsgBox"隐藏当前单元格所在列"
iColumn=
s(iColumn).Hidden=True
MsgBox"取消隐藏"
s(iColumn).Hidden=False
EndSub
--------------------------------------------------------------------------------
[示例04-11-03]插入行
SubInsertRow()
DimrRowAsLong
MsgBox"在当前单元格上方插入一行"
rRow=
(rRow).Insert
EndSub
--------------------------------------------------------------------------------
[示例04-11-04]插入列
SubInsertColumn()
DimcColumnAsLong
MsgBox"在当前单元格所在行的左边插入一行"
cColumn=
s(cColumn).Insert
EndSub
--------------------------------------------------------------------------------
[示例04-11-05]插入多行
SubInsertManyRow()
MsgBox"在当前单元格所在行上方插入三行"
DimrRowAsLong,iAsLong
Fori=1To3
rRow=
(rRow).Insert
Nexti
EndSub
--------------------------------------------------------------------------------
[示例04-11-06]设置行高
SubSetRowHeight()
MsgBox"将当前单元格所在的行高设置为25"
DimrRowAsLong,iRowAsLong
rRow=
iRow=(rRow).RowHeight
(rRow).RowHeight=25
MsgBox"恢复到原来的行高"
(rRow).RowHeight=iRow
EndSub
--------------------------------------------------------------------------------
[示例04-11-07]设置列宽
SubSetColumnWidth()
MsgBox"将当前单元格所在列的列宽设置为20"
DimcColumnAsLong,iColumnAsLong
cColumn=
iColumn=s(cColumn).ColumnWidth
s(cColumn).ColumnWidth=20
MsgBox"恢复至原来的列宽"
s(cColumn).ColumnWidth=iColumn
EndSub
--------------------------------------------------------------------------------
[示例04-11-08]恢复行高列宽至标准值
SubReSetRowHeightAndColumnWidth()
MsgBox"将当前单元格所在的行高和列宽恢复为标准值"
ndardHeight=True
ndardWidth=True
EndSub
--------------------------------------------------------------------------------
[示例04-12]工作表标签
[示例04-12-01]设置工作表标签的颜色
SubSetSheetTabColor()
MsgBox"设置当前工作表标签的颜色"
ndex=7
EndSub
--------------------------------------------------------------------------------
[示例04-12-01]恢复工作表标签颜色
SubSetSheetTabColorDefault()
MsgBox"将当前工作表标签颜色设置为默认值"
ndex=-4142
EndSub
--------------------------------------------------------------------------------
[示例04-12-03]交替隐藏或显示工作表标签
SubHideOrShowSheetTab()
MsgBox"隐藏/显示工作表标签"
yWorkbookTabs=yWorkbookTabs
EndSub
-------------------------------------------------------------------------
SubPageCount()
DimiAsLong
i=(+1)*(+1)
MsgBox"当前工作表共"&i&"页."
EndSub
--------------------------------------------------------------------------------
[示例04-14]保护/撤销保护工作表
[示例04-14-01]
SubProtectSheet()
MsgBox"保护当前工作表并设定密码"
tPassword:="fanjy"
EndSub
示例说明：运行代码后，当前工作表中将不允许编辑，除非撤销工作表保护。
--------------------------------------------------------------------------------
[示例04-14-02]
SubUnprotectSheet()
MsgBox"撤销当前工作表保护"
ect
EndSub
示例说明：运行代码后，如果原保护的工作表设置有密码，则要求输入密码。
--------------------------------------------------------------------------------
[示例04-14-03]保护当前工作簿中的所有工作表
SubProtectAllWorkSheets()
OnErrorResumeNext
DimwsAsWorksheet
DimmyPasswordAsString
myPassword=InputBox("请输入您的密码"&vbCrLf&_
"(不输入表明无密码)"&vbCrLf&vbCrLf&_
"确保您没有忘记密码！","输入密码")
eets
t(myPassword)
Nextws
EndSub
--------------------------------------------------------------------------------
[示例04-14-04]撤销对当前工作簿中所有工作表的保护
SubUnprotectAllWorkSheets()
OnErrorResumeNext
DimwsAsWorksheet
DimmyPasswordAsString
myPassword=InputBox("请输入您的密码"&vbCrLf&_
"(不输入表示无密码)","输入密码")
eets
ect(myPassword)
Nextws
EndSub
--------------------------------------------------------------------------------
[示例04-14-05]仅能编辑未锁定的单元格
SubOnlyEditUnlockedCells()
Sheets("Sheet1").EnableSelection=xlUnlockedCells
tDrawingObjects:=True,Contents:=True,Scenarios:=True
EndSub
示例说明：运行本代码后，在当前工作表中将只能对未锁定的单元格进行编辑，而其它单元格将不能编辑。未锁
定的单元格是指在选择菜单“格式——单元格”命令后所弹出的对话框中的“保护”选项卡中，未选中“锁定”复选框
的单元格或单元格区域。
--------------------------------------------------------------------------------
[示例04-15]删除工作表(Delete方法)
SubDeleteWorksheet()
MsgBox"删除当前工作簿中的工作表sheet2"
yAlerts=False
Worksheets("sheet2").Delete
yAlerts=True
EndSub
示例说明：本示例代码使用yAlerts=False来屏蔽弹出的警告框。
--------------------------------------------------------------------------------
<一些编程方法和技巧>
[示例04-16]判断一个工作表(名)是否存在
[示例04-16-01]
SubtestWorksheetExists1()
DimwsAsWorksheet
IfNotWorksheetExists(ThisWorkbook,"sheet1")Then
MsgBox"不能够找到该工作表",vbOKOnly
ExitSub
EndIf
MsgBox"已经找到工作表"
Setws=eets("sheet1")
EndSub
'-------------------
FunctionWorksheetExists(wbAsWorkbook,sNameAsString)AsBoolean
DimsAsString
OnErrorGoToErrHandle
s=eets(sName).Name
WorksheetExists=True
ExitFunction
ErrHandle:
WorksheetExists=False
EndFunction
示例说明：在测试代码中，用相应的工作簿名和工作表名分别代替“ThisWorkbook”和“Sheet1”，来判断指定工
作表是否在工作簿中存在。
--------------------------------------------------------------------------------
[示例04-16-02]
SubtestWorksheetExists2()
IfNotSheetExists("<工作表名>")Then
MsgBox"<工作表名>不存在!"
Else
Sheets("<工作表名>").Activate
EndIf
EndSub
'-------------------
FunctionSheetExists(SheetNameAsString)AsBoolean
SheetExists=False
OnErrorGoToNoSuchSheet
IfLen(Sheets(SheetName).Name)>0Then
SheetExists=True
ExitFunction
EndIf
NoSuchSheet:
EndFunction
示例说明：在代码中，用实际工作表名代替<>。
--------------------------------------------------------------------------------
[示例04-16-03]
SubTestingFunction()
'如果工作表存在则返回True，否则为False
'测试DoesWksExist1函数
oesWksExist1("Sheet1")
oesWksExist1("Sheet100")
"-----"
'测试DoesWksExist2函数
oesWksExist2("Sheet1")
oesWksExist2("Sheet100")
EndSub
‘-------------------------------
FunctionDoesWksExist1(sWksNameAsString)AsBoolean
DimiAsLong
Fori=o1Step-1
IfSheets(i).Name=sWksNameThen
ExitFor
EndIf
Next
Ifi=0Then
DoesWksExist1=False
Else
DoesWksExist1=True
EndIf
EndFunction
‘-------------------------------
FunctionDoesWksExist2(sWksNameAsString)AsBoolean
DimwkbAsWorksheet
OnErrorResumeNext
Setwkb=Sheets(sWksName)
OnErrorGoTo0
DoesWksExist2=IIf(NotwkbIsNothing,True,False)
EndFunction
--------------------------------------------------------------------------------
[示例04-17]排序工作表
[示例04-17-01]
SubSortWorksheets1()
DimbSortedAsBoolean
DimnSortedSheetsAsLong
DimnSheetsAsLong
DimnAsLong
nSheets=
nSortedSheets=0
DoWhile(nSortedSheets bSorted=True nSortedSheets=nSortedSheets+1 Forn=1TonSheets-nSortedSheets IfStrComp(Worksheets(n).Name,Worksheets(n+1).Name,vbTextCompare)>0Then Worksheets(n+1).MoveBefore:=Worksheets(n) bSorted=False EndIf Nextn Loop EndSub 示例说明：本示例代码采用了冒泡法排序。 -------------------------------------------------------------------------------- [示例04-17-02] SubSortWorksheets2() '根据字母对工作表排序 DimiAsLong,jAsLong Fori= Forj=-1 IfUCase$(Sheets(j).Name)>UCase$(Sheets(j+1).Name)Then Sheets(j).MoveAfter:=Sheets(j+1) EndIf Nextj Nexti EndSub -------------------------------------------------------------------------------- [示例04-17-03] SubSortWorksheets3() '以升序排列工作表 DimsCountAsInteger,iAsInteger,jAsInteger Updating=False sCount= IfsCount=1ThenExitSub Fori=1TosCount-1 Forj=i+1TosCount IfWorksheets(j).Name Worksheets(j).MoveBefore:=Worksheets(i) EndIf Nextj Nexti EndSub 示例说明：若想排序所有工作表，将代码中的Worksheets替换为Sheets。 -------------------------------------------------------------------------------- [示例04-18]删除当前工作簿中的空工作表 SubDelete_EmptySheets() DimshAsWorksheet eets ()=0Then yAlerts=False yAlerts=True EndIf Next EndSub --------------------------------------- ----以下是些同事们编写的vba宏，贴出来供参考 --------------------------------------- OptionExplicit ''''''''''''''''''''''''''''''' 'CCB·先进数通·联想利泰·崔铂 ''''''''''''''''''''''''''''''' PublicConstAPPNAME="CuiBo_VBA_Tools" PrivateConstODBC_ADD_DSN=1'Adddatasource PrivateConstODBC_CONFIG_DSN=2'Configure(edit)datasource PrivateConstODBC_REMOVE_DSN=3'Removedatasource PrivateConstODBC_ADD_SYS_DSN=4'Adddatasource PrivateConstODBC_CONFIG_SYS_DSN=5'Configure(edit)datasource PrivateConstODBC_REMOVE_SYS_DSN=6'Removedatasource PrivateConstvbAPINullAsLong=0&'NULLPointer PrivateDeclareFunctionSQLConfigDataSourceLib""(ByValhwndParentAsLong, ByValfRequestAsLong,ByVallpszDriverAsString,ByVallpszAttributesAsString)AsLong Sub根据字段级映射关系生成数据库Comment语句() DimshAsWorksheet,sFileAsString,sAsString DimcAsCollection,iNumAsInteger DimiFieldCountAsInteger,iLineCountAsInteger,iAsInteger DimsTbInfoAsString,sFieldInfoAsString,sTableAsString,sFieldAsString Setsh=FindParaSheet("映射关系","字段级映射关系") IfshIsNothingThen MsgBox"找不到字段级映射关系表单,请打开相应文件!",vbInformation ExitSub EndIf '("$N$4").Row&","&("$N$4").Column s= s=Left(s,Len(s)-4)&".sql" sFile=eAsFilename(s,"(*.sql),*.sql",,"请选择将要生成的sql文件的保存位置") IfsFile="False"ThenExitSub iNum=FreeFile OpensFileForOutputAs#iNum Setc=NewCollection i=4 OnLocalErrorResumeNext Withsh Do sTable=.Cells(i,14) sField=.Cells(i,17) IfsField=""OrsTable=""ThenExitDo sFieldInfo=.Cells(i,18) IfsTable<>c(sTable)Then sTbInfo=.Cells(i,13) ble,sTable Print#iNum,"commentontable"&sTable&"is'"&sTbInfo&"';" iLineCount=iLineCount+1 EndIf Print#iNum,"commentoncolumn"&sTable&"."&sField&"is'"&sFieldInfo;"';" iFieldCount=iFieldCount+1 iLineCount=iLineCount+1 i=i+1 Loop EndWith Close MsgBox"成功写入"&&"个表、"&iFieldCount&"个字段的Comment语句，共"&iLineCount &"行"&vbCrLf&"到文件:"&sFile Setc=Nothing Setsh=Nothing EndSub Sub参数入Oracle临时表() DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger,iBlank2AsInteger Dimsh4AsWorksheet,sh5AsWorksheet OnErrorGoToErrh Setsh4=FindParaSheet() Setsh5=FindParaSheet("信息登记(集成测试)") Ifsh4IsNothingOrsh5IsNothingThen MsgBox"不存在Job参数登记的表单!",vbExclamation End EndIf 'sh4和sh5对应表但 iBlank1=FindBlankLine(sh4) iBlank2=FindBlankLine(sh5) IfiBlank1<=3AndiBlank2<=4Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") '"adt2b","adt2b","adt2b" e("selectcount(*)fromds_t_jobj,ds_t_jobparampwhere e=e")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromds_t_job") e("deletefromds_t_jobparam") ElseIfi=elThen Setconn=Nothing ExitSub EndIf EndIf rans Fori=4ToiBlank2-1 Withsh5 s="insertintods_t_jobvalues('"&.Cells(i,1) Forj=2To9 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Fori=3ToiBlank1-1 Withsh4 s="insertintods_t_jobparamvalues('"&.Cells(i,1) Forj=2To13 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-3&"条记录到参数表！"&vbCrLf_ &"成功插入"&iBlank2-4&"条记录到Job表！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub SubCycle配置入Oracle临时表(OptionalshAsWorksheet=Nothing) DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger OnErrorGoToErrh IfshIsNothingThen Setsh=("临时表") EndIf iBlank1=FindBlankLine(sh) IfiBlank1<=2Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") rans e("selectcount(*)fromds_t_cycle")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromDS_T_CYCLE") ElseIfi=elThen ckTrans Setconn=Nothing ExitSub EndIf EndIf Fori=2ToiBlank1-1 Withsh s="insertintoDS_T_CYCLEvalues('"&.Cells(i,2) Forj=3To14 s=s&"','"&.Cells(i,j) Next s=s&"')" 'MsgBoxs e(s) EndWith Next 'e("deletefromdepend_cfgdwhereexists(select*fromds_t_cyclewhere jobname=_name)") 'e("insertintodepend_cfgselectdistinctsou_sys,jobname,description,spcjobfrom ds_t_cyclewherecytype='depend'") Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-2&"条记录到临时表DS_T_Cycle！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub '只在某一workbook中寻找包含name的sheet FunctionFindSheet(wbAsWorkbook,sNameAsString)AsWorksheet DimshAsWorksheet IfInStr(,sName)Then SetFindSheet=sh ExitFor EndIf Next EndFunction SubCycle配置组合为临时表() DimwbAsWorkbook Dimsh21AsWorksheet,sh24AsWorksheet,sh25AsWorksheet,sh3AsWorksheet DimshtAsWorksheet,iAsInteger,iCountAsInteger,iTindexAsInteger DimJobs()AsString,sJobAsString,iJobIndexAsInteger,iDupCountAsInteger OnErrorGoToErrh Setwb=Workbook Setsh21=("2.1公共作业配置－增量合并全量") Setsh24=FindSheet(wb,"2.4公共作业配置-T-1机构") Setsh25=FindSheet(wb,"2.5公共作业配置-FDM全量库ECIF客户号更新") Setsh3=("3.作业依赖关系") OnErrorResumeNext Setsht=eets("临时表") IfshtIsNothingThen 3 Setsht=ActiveSheet e=xlSheetVisible WithSheet9 =sht 2=ects(1).Object EndWith EndIf i=FindBlankLine(sht,"B",1) Ifi>2Then ("$A$3:$Z$"&i).Delete EndIf '''''''''提取四个表内容 iTindex=2 Withsht '2.1公共作业配置－增量合并全量 iCount=FindBlankLine(sh21,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)="ccbs" 'INDEX 'JOBNAME 'DESC .Cells(iTindex,2)=sJob'(i,2) 'SOU_SYS .Cells(iTindex,5)=(i,11)'BRANCH .Cells(iTindex,6)=(i,10)'YWLX .Cells(iTindex,7)=(i,13)'YXPD .Cells(iTindex,8)=(i,14)'YXJ .Cells(iTindex,9)="E" 'SOURCE_TABLE .Cells(iTindex,12)=(i,6)'LDM_TABLE .Cells(iTindex,13)="add2all" iJobIndex=iJobIndex+1 iTindex=iTindex+1 EndIf Next '2.4公共作业配置-T-1机构拆并 iCount=FindBlankLine(sh24,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)="ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex,14)=(i,12)'BZ 'JOBTYPE .Cells(iTindex,11)=Replace(Replace((i,5),vbCrLf,"/"),vbLf,"/") 'SOU_SYS .Cells(iTindex,5)=(i,7)'BRANCH .Cells(iTindex,6)=(i,6)'YWLX .Cells(iTindex,7)=(i,8)'YXPD .Cells(iTindex,8)=(i,9)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="orgmerg" iTindex=iTindex+1 EndIf Next 'FDM全量库ECIF客户号更新 iCount=FindBlankLine(sh25,"B") iJobIndex=0 Fori=3ToiCount-1 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)=(i,1) .Cells(iTindex,6)="ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX .Cells(iTindex,5)=(i,5)'BRANCH .Cells(iTindex,7)=(i,6)'YXPD .Cells(iTindex,8)=(i,7)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="ecifacc" iTindex=iTindex+1 EndIf Next '3.作业依赖关系 iCount=FindBlankLine(sh3,"B") DimsAsString Fori=2ToiCount-1 IfLCase((i,1))="ccbs"Then .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) 'INDEX 'JOBNAME 'DESC 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ .Cells(iTindex,4)="ccbs"'(i,1) .Cells(iTindex,9)="E" s=(i,4) .Cells(iTindex,10)=s'(i,4) .Cells(iTindex,13)="depend" 'IfiTindex=270ThenStop iTindex=iTindex+1 EndIf Next EndWith 'SOU_SYS 'JOBTYPE 'CTYPE IfiDupCount>0ThenMsgBox"有"&iDupCount&"个重复的逻辑JOB!",vbInformation ExitSub Errh: MsgBox"请在Cycle配置文档下执行此宏!",vbInformation ' EndSub '公共函数：使用oracle数据库前执行检查，是否存在ODBC数据源adt2b，如没有引导用户添加 '如已有或成功添加后打开并返回connection '''''''''''''''''''''''''''''''''''''''''''''''''' FunctionOpenOraDSN(OptionaldsnAsString="adt2b")AsConnection DimiRetAsLong,sDriverAsString,sConnAsString DimsServerAsString,sUserAsString,sPassAsString DimcAsConnection OnErrorGoToErrh sDriver="MicrosoftODBCforOracle" sConn="DSN="&dsn IfSQLConfigDataSource(vbAPINull,ODBC_CONFIG_SYS_DSN,sDriver,sConn)=0Then MsgBox"没有创建名为"&dsn&"的数据源！"&vbCrLf&"点确定后将会引导你创建.(需要先安装 oracle客户端，并配置好到数据库服务器的连接)",vbInformation sServer=InputBox("例如:odsptcs","请输入Oracle配置的连接服务名","odsptcs") IfsServer=""ThenEnd sUser=InputBox("例如:adt2b","请输入Oracle用户名","adt2b") IfsUser=""ThenEnd sPass=InputBox("例如:adt2b","请输入Oracle用户的密码","adt2b") IfsPass=""ThenEnd sConn=sConn&Chr(0)&"SERVER="&sServer&Chr(0)&"UID="&sUser&Chr(0)& "PWD="&sPass iRet=SQLConfigDataSource(vbAPINull,ODBC_ADD_SYS_DSN,sDriver,sConn) IfiRetThen SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass MsgBox"数据源DSN创建成功！",vbInformation Else MsgBox"数据源DSN创建失败！",vbExclamation End EndIf Else sUser=GetSetting(APPNAME,"DSN",dsn&".UID") sPass=GetSetting(APPNAME,"DSN",dsn&".PWD") DoWhilesUser="" sUser=InputBox("","请输入Oracle用户名","adt2b") Loop DoWhilesPass="" sPass=InputBox("","请输入Oracle用户的密码","adt2b") Loop SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass EndIf Setc=NewConnection "DSN="&dsn,sUser,sPass SetOpenOraDSN=c ExitFunction Errh: ption,vbCritical,"打开数据库失败" End EndFunction -------------------------------------------------------------------- OptionExplicit ''''''''''''''''''''''''''''''' PublicConstAPPNAME="CuiBo_VBA_Tools" PrivateConstODBC_ADD_DSN=1'Adddatasource PrivateConstODBC_CONFIG_DSN=2'Configure(edit)datasource PrivateConstODBC_REMOVE_DSN=3'Removedatasource PrivateConstODBC_ADD_SYS_DSN=4'Adddatasource PrivateConstODBC_CONFIG_SYS_DSN=5'Configure(edit)datasource PrivateConstODBC_REMOVE_SYS_DSN=6'Removedatasource PrivateConstvbAPINullAsLong=0&'NULLPointer PrivateDeclareFunctionSQLConfigDataSourceLib""(ByValhwndParentAsLong, ByValfRequestAsLong,ByVallpszDriverAsString,ByVallpszAttributesAsString)AsLong Sub根据字段级映射关系生成数据库Comment语句() DimshAsWorksheet,sFileAsString,sAsString DimcAsCollection,iNumAsInteger DimiFieldCountAsInteger,iLineCountAsInteger,iAsInteger DimsTbInfoAsString,sFieldInfoAsString,sTableAsString,sFieldAsString Setsh=FindParaSheet("映射关系","字段级映射关系") IfshIsNothingThen MsgBox"找不到字段级映射关系表单,请打开相应文件!",vbInformation ExitSub EndIf '("$N$4").Row&","&("$N$4").Column s= s=Left(s,Len(s)-4)&".sql" sFile=eAsFilename(s,"(*.sql),*.sql",,"请选择将要生成的sql文件的保存位置") IfsFile="False"ThenExitSub iNum=FreeFile OpensFileForOutputAs#iNum Setc=NewCollection i=4 OnLocalErrorResumeNext Withsh Do sTable=.Cells(i,14) sField=.Cells(i,17) IfsField=""OrsTable=""ThenExitDo sFieldInfo=.Cells(i,18) IfsTable<>c(sTable)Then sTbInfo=.Cells(i,13) ble,sTable Print#iNum,"commentontable"&sTable&"is'"&sTbInfo&"';" iLineCount=iLineCount+1 EndIf Print#iNum,"commentoncolumn"&sTable&"."&sField&"is'"&sFieldInfo;"';" iFieldCount=iFieldCount+1 iLineCount=iLineCount+1 i=i+1 Loop EndWith Close MsgBox"成功写入"&&"个表、"&iFieldCount&"个字段的Comment语句，共"&iLineCount &"行"&vbCrLf&"到文件:"&sFile Setc=Nothing Setsh=Nothing EndSub Sub参数入Oracle临时表() DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger,iBlank2AsInteger Dimsh4AsWorksheet,sh5AsWorksheet OnErrorGoToErrh Setsh4=FindParaSheet() Setsh5=FindParaSheet("信息登记(集成测试)") Ifsh4IsNothingOrsh5IsNothingThen MsgBox"不存在Job参数登记的表单!",vbExclamation End EndIf 'sh4和sh5对应表但 iBlank1=FindBlankLine(sh4) iBlank2=FindBlankLine(sh5) IfiBlank1<=3AndiBlank2<=4Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") '"adt2b","adt2b","adt2b" e("selectcount(*)fromds_t_jobj,ds_t_jobparampwhere e=e")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromds_t_job") e("deletefromds_t_jobparam") ElseIfi=elThen Setconn=Nothing ExitSub EndIf EndIf rans Fori=4ToiBlank2-1 Withsh5 s="insertintods_t_jobvalues('"&.Cells(i,1) Forj=2To9 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Fori=3ToiBlank1-1 Withsh4 s="insertintods_t_jobparamvalues('"&.Cells(i,1) Forj=2To13 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-3&"条记录到参数表！"&vbCrLf_ &"成功插入"&iBlank2-4&"条记录到Job表！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub SubCycle配置入Oracle临时表(OptionalshAsWorksheet=Nothing) DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger OnErrorGoToErrh IfshIsNothingThen Setsh=("临时表") EndIf iBlank1=FindBlankLine(sh) IfiBlank1<=2Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") rans e("selectcount(*)fromds_t_cycle")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromDS_T_CYCLE") ElseIfi=elThen ckTrans Setconn=Nothing ExitSub EndIf EndIf Fori=2ToiBlank1-1 Withsh s="insertintoDS_T_CYCLEvalues('"&.Cells(i,2) Forj=3To14 s=s&"','"&.Cells(i,j) Next s=s&"')" 'MsgBoxs e(s) EndWith Next 'e("deletefromdepend_cfgdwhereexists(select*fromds_t_cyclewhere jobname=_name)") 'e("insertintodepend_cfgselectdistinctsou_sys,jobname,description,spcjobfrom ds_t_cyclewherecytype='depend'") Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-2&"条记录到临时表DS_T_Cycle！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub '只在某一workbook中寻找包含name的sheet FunctionFindSheet(wbAsWorkbook,sNameAsString)AsWorksheet DimshAsWorksheet IfInStr(,sName)Then SetFindSheet=sh ExitFor EndIf Next EndFunction SubCycle配置组合为临时表() DimwbAsWorkbook Dimsh21AsWorksheet,sh24AsWorksheet,sh25AsWorksheet,sh3AsWorksheet DimshtAsWorksheet,iAsInteger,iCountAsInteger,iTindexAsInteger DimJobs()AsString,sJobAsString,iJobIndexAsInteger,iDupCountAsInteger OnErrorGoToErrh Setwb=Workbook Setsh21=("2.1公共作业配置－增量合并全量") Setsh24=FindSheet(wb,"2.4公共作业配置-T-1机构") Setsh25=FindSheet(wb,"2.5公共作业配置-FDM全量库ECIF客户号更新") Setsh3=("3.作业依赖关系") OnErrorResumeNext Setsht=eets("临时表") IfshtIsNothingThen 3 Setsht=ActiveSheet e=xlSheetVisible WithSheet9 =sht 2=ects(1).Object EndWith EndIf i=FindBlankLine(sht,"B",1) Ifi>2Then ("$A$3:$Z$"&i).Delete EndIf '''''''''提取四个表内容 iTindex=2 Withsht '2.1公共作业配置－增量合并全量 iCount=FindBlankLine(sh21,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,3)=(i,3) 'INDEX 'JOBNAME 'DESC .Cells(iTindex,2)=sJob'(i,2) .Cells(iTindex,4)="ccbs"'SOU_SYS .Cells(iTindex,5)=(i,11)'BRANCH .Cells(iTindex,6)=(i,10)'YWLX .Cells(iTindex,7)=(i,13)'YXPD .Cells(iTindex,8)=(i,14)'YXJ .Cells(iTindex,9)="E" 'SOURCE_TABLE .Cells(iTindex,12)=(i,6)'LDM_TABLE .Cells(iTindex,13)="add2all" iJobIndex=iJobIndex+1 iTindex=iTindex+1 EndIf Next '2.4公共作业配置-T-1机构拆并 iCount=FindBlankLine(sh24,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)="ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex,14)=(i,12)'BZ 'JOBTYPE .Cells(iTindex,11)=Replace(Replace((i,5),vbCrLf,"/"),vbLf,"/") 'SOU_SYS .Cells(iTindex,5)=(i,7)'BRANCH .Cells(iTindex,6)=(i,6)'YWLX .Cells(iTindex,7)=(i,8)'YXPD .Cells(iTindex,8)=(i,9)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="orgmerg" iTindex=iTindex+1 EndIf Next 'FDM全量库ECIF客户号更新 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ iCount=FindBlankLine(sh25,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)=(i,1) .Cells(iTindex,6)="ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX .Cells(iTindex,5)=(i,5)'BRANCH .Cells(iTindex,7)=(i,6)'YXPD .Cells(iTindex,8)=(i,7)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="ecifacc" iTindex=iTindex+1 EndIf Next '3.作业依赖关系 iCount=FindBlankLine(sh3,"B") DimsAsString Fori=2ToiCount-1 IfLCase((i,1))="ccbs"Then .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,9)="E" s=(i,4) .Cells(iTindex,10)=s'(i,4) .Cells(iTindex,13)="depend" 'IfiTindex=270ThenStop iTindex=iTindex+1 EndIf Next 'CTYPE 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'JOBTYPE 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ .Cells(iTindex,4)="ccbs"'(i,1) EndWith IfiDupCount>0ThenMsgBox"有"&iDupCount&"个重复的逻辑JOB!",vbInformation ExitSub Errh: MsgBox"请在Cycle配置文档下执行此宏!",vbInformation ' EndSub '公共函数：使用oracle数据库前执行检查，是否存在ODBC数据源adt2b，如没有引导用户添加 '如已有或成功添加后打开并返回connection '''''''''''''''''''''''''''''''''''''''''''''''''' FunctionOpenOraDSN(OptionaldsnAsString="adt2b")AsConnection DimiRetAsLong,sDriverAsString,sConnAsString DimsServerAsString,sUserAsString,sPassAsString DimcAsConnection OnErrorGoToErrh sDriver="MicrosoftODBCforOracle" sConn="DSN="&dsn IfSQLConfigDataSource(vbAPINull,ODBC_CONFIG_SYS_DSN,sDriver,sConn)=0Then MsgBox"没有创建名为"&dsn&"的数据源！"&vbCrLf&"点确定后将会引导你创建.(需要先安装 oracle客户端，并配置好到数据库服务器的连接)",vbInformation sServer=InputBox("例如:odsptcs","请输入Oracle配置的连接服务名","odsptcs") IfsServer=""ThenEnd sUser=InputBox("例如:adt2b","请输入Oracle用户名","adt2b") IfsUser=""ThenEnd sPass=InputBox("例如:adt2b","请输入Oracle用户的密码","adt2b") IfsPass=""ThenEnd sConn=sConn&Chr(0)&"SERVER="&sServer&Chr(0)&"UID="&sUser&Chr(0)& "PWD="&sPass iRet=SQLConfigDataSource(vbAPINull,ODBC_ADD_SYS_DSN,sDriver,sConn) IfiRetThen SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass MsgBox"数据源DSN创建成功！",vbInformation Else MsgBox"数据源DSN创建失败！",vbExclamation End EndIf Else sUser=GetSetting(APPNAME,"DSN",dsn&".UID") sPass=GetSetting(APPNAME,"DSN",dsn&".PWD") DoWhilesUser="" sUser=InputBox("","请输入Oracle用户名","adt2b") Loop DoWhilesPass="" sPass=InputBox("","请输入Oracle用户的密码","adt2b") Loop SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass EndIf Setc=NewConnection "DSN="&dsn,sUser,sPass SetOpenOraDSN=c ExitFunction Errh: ption,vbCritical,"打开数据库失败" End EndFunction ---------------------------------------------------------------------------- OptionExplicit ''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''' PublicConstAPPNAME="CuiBo_VBA_Tools" PrivateConstODBC_ADD_DSN=1'Adddatasource PrivateConstODBC_CONFIG_DSN=2'Configure(edit)datasource PrivateConstODBC_REMOVE_DSN=3'Removedatasource PrivateConstODBC_ADD_SYS_DSN=4'Adddatasource PrivateConstODBC_CONFIG_SYS_DSN=5'Configure(edit)datasource PrivateConstODBC_REMOVE_SYS_DSN=6'Removedatasource PrivateConstvbAPINullAsLong=0&'NULLPointer PrivateDeclareFunctionSQLConfigDataSourceLib""(ByValhwndParentAsLong, ByValfRequestAsLong,ByVallpszDriverAsString,ByVallpszAttributesAsString)AsLong Sub根据字段级映射关系生成数据库Comment语句() DimshAsWorksheet,sFileAsString,sAsString DimcAsCollection,iNumAsInteger DimiFieldCountAsInteger,iLineCountAsInteger,iAsInteger DimsTbInfoAsString,sFieldInfoAsString,sTableAsString,sFieldAsString Setsh=FindParaSheet("映射关系","字段级映射关系") IfshIsNothingThen MsgBox"找不到字段级映射关系表单,请打开相应文件!",vbInformation ExitSub EndIf '("$N$4").Row&","&("$N$4").Column s= s=Left(s,Len(s)-4)&".sql" sFile=eAsFilename(s,"(*.sql),*.sql",,"请选择将要生成的sql文件的保存位置") IfsFile="False"ThenExitSub iNum=FreeFile OpensFileForOutputAs#iNum Setc=NewCollection i=4 OnLocalErrorResumeNext Withsh Do sTable=.Cells(i,14) sField=.Cells(i,17) IfsField=""OrsTable=""ThenExitDo sFieldInfo=.Cells(i,18) IfsTable<>c(sTable)Then sTbInfo=.Cells(i,13) ble,sTable Print#iNum,"commentontable"&sTable&"is'"&sTbInfo&"';" iLineCount=iLineCount+1 EndIf Print#iNum,"commentoncolumn"&sTable&"."&sField&"is'"&sFieldInfo;"';" iFieldCount=iFieldCount+1 iLineCount=iLineCount+1 i=i+1 Loop EndWith Close MsgBox"成功写入"&&"个表、"&iFieldCount&"个字段的Comment语句，共"&iLineCount &"行"&vbCrLf&"到文件:"&sFile Setc=Nothing Setsh=Nothing EndSub Sub参数入Oracle临时表() DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger,iBlank2AsInteger Dimsh4AsWorksheet,sh5AsWorksheet OnErrorGoToErrh Setsh4=FindParaSheet() Setsh5=FindParaSheet("信息登记(集成测试)") Ifsh4IsNothingOrsh5IsNothingThen MsgBox"不存在Job参数登记的表单!",vbExclamation End EndIf 'sh4和sh5对应表但 iBlank1=FindBlankLine(sh4) iBlank2=FindBlankLine(sh5) IfiBlank1<=3AndiBlank2<=4Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") '"adt2b","adt2b","adt2b" e("selectcount(*)fromds_t_jobj,ds_t_jobparampwhere e=e")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromds_t_job") e("deletefromds_t_jobparam") ElseIfi=elThen Setconn=Nothing ExitSub EndIf EndIf rans Fori=4ToiBlank2-1 Withsh5 s="insertintods_t_jobvalues('"&.Cells(i,1) Forj=2To9 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Fori=3ToiBlank1-1 Withsh4 s="insertintods_t_jobparamvalues('"&.Cells(i,1) Forj=2To13 s=s&"','"&.Cells(i,j) Next s=s&"')" e(s) EndWith Next Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-3&"条记录到参数表！"&vbCrLf_ &"成功插入"&iBlank2-4&"条记录到Job表！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub SubCycle配置入Oracle临时表(OptionalshAsWorksheet=Nothing) DimiAsInteger,jAsInteger,sAsString DimconnAsConnection DimiBlank1AsInteger OnErrorGoToErrh IfshIsNothingThen Setsh=("临时表") EndIf iBlank1=FindBlankLine(sh) IfiBlank1<=2Then MsgBox"没有数据需要添入表！",vbInformation ExitSub EndIf '添加名为adt2b的ODBC数据源(添加时要用到oracle客户端配置的连接标识/ServiceName) 'dsnuserpassword Setconn=OpenOraDSN("adt2b") rans e("selectcount(*)fromds_t_cycle")(0)>0Then i=MsgBox("数据库临时表中有数据，是否删除?",vbYesNoCancel) Ifi=vbYesThen e("deletefromDS_T_CYCLE") ElseIfi=elThen ckTrans Setconn=Nothing ExitSub EndIf EndIf Fori=2ToiBlank1-1 Withsh s="insertintoDS_T_CYCLEvalues('"&.Cells(i,2) Forj=3To14 s=s&"','"&.Cells(i,j) Next s=s&"')" 'MsgBoxs e(s) EndWith Next 'e("deletefromdepend_cfgdwhereexists(select*fromds_t_cyclewhere jobname=_name)") 'e("insertintodepend_cfgselectdistinctsou_sys,jobname,description,spcjobfrom ds_t_cyclewherecytype='depend'") Trans Setconn=Nothing MsgBox"成功插入"&iBlank1-2&"条记录到临时表DS_T_Cycle！",vbInformation ExitSub Errh: ption,vbCritical IfNotconnIsNothingThen =1Then ckTrans EndIf Setconn=Nothing EndIf EndSub '只在某一workbook中寻找包含name的sheet FunctionFindSheet(wbAsWorkbook,sNameAsString)AsWorksheet DimshAsWorksheet IfInStr(,sName)Then SetFindSheet=sh ExitFor EndIf Next EndFunction SubCycle配置组合为临时表() DimwbAsWorkbook Dimsh21AsWorksheet,sh24AsWorksheet,sh25AsWorksheet,sh3AsWorksheet DimshtAsWorksheet,iAsInteger,iCountAsInteger,iTindexAsInteger DimJobs()AsString,sJobAsString,iJobIndexAsInteger,iDupCountAsInteger OnErrorGoToErrh Setwb=Workbook Setsh21=("2.1公共作业配置－增量合并全量") Setsh24=FindSheet(wb,"2.4公共作业配置-T-1机构") Setsh25=FindSheet(wb,"2.5公共作业配置-FDM全量库ECIF客户号更新") Setsh3=("3.作业依赖关系") OnErrorResumeNext Setsht=eets("临时表") IfshtIsNothingThen 3 Setsht=ActiveSheet e=xlSheetVisible WithSheet9 =sht 2=ects(1).Object EndWith EndIf i=FindBlankLine(sht,"B",1) Ifi>2Then ("$A$3:$Z$"&i).Delete EndIf '''''''''提取四个表内容 iTindex=2 Withsht '2.1公共作业配置－增量合并全量 iCount=FindBlankLine(sh21,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)="ccbs" 'INDEX 'JOBNAME 'DESC .Cells(iTindex,2)=sJob'(i,2) 'SOU_SYS .Cells(iTindex,5)=(i,11)'BRANCH .Cells(iTindex,6)=(i,10)'YWLX .Cells(iTindex,7)=(i,13)'YXPD .Cells(iTindex,8)=(i,14)'YXJ .Cells(iTindex,9)="E" 'SOURCE_TABLE 'JOBTYPE .Cells(iTindex,11)=Replace(Replace((i,5),vbCrLf,"/"),vbLf,"/") .Cells(iTindex,12)=(i,6)'LDM_TABLE .Cells(iTindex,13)="add2all" iJobIndex=iJobIndex+1 iTindex=iTindex+1 EndIf Next '2.4公共作业配置-T-1机构拆并 iCount=FindBlankLine(sh24,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)="ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex,14)=(i,12)'BZ 'SOU_SYS .Cells(iTindex,5)=(i,7)'BRANCH .Cells(iTindex,6)=(i,6)'YWLX .Cells(iTindex,7)=(i,8)'YXPD .Cells(iTindex,8)=(i,9)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="orgmerg" iTindex=iTindex+1 EndIf Next 'FDM全量库ECIF客户号更新 iCount=FindBlankLine(sh25,"B") iJobIndex=0 Fori=3ToiCount-1 IfLCase((i,1))="ccbs"Then ReDimPreserveJobs(iJobIndex) sJob=(i,2) IfInArr(sJob,Jobs)>0Then iDupCount=iDupCount+1 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ .Range("$A$"&iTindex&":$Z$"&iTindex).ndex=36 EndIf Jobs(iJobIndex)=sJob .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,4)=(i,1) .Cells(iTindex,6)="ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX .Cells(iTindex,5)=(i,5)'BRANCH .Cells(iTindex,7)=(i,6)'YXPD .Cells(iTindex,8)=(i,7)'YXJ .Cells(iTindex,9)="E" .Cells(iTindex,11)="" .Cells(iTindex,13)="ecifacc" iTindex=iTindex+1 EndIf Next '3.作业依赖关系 iCount=FindBlankLine(sh3,"B") DimsAsString Fori=2ToiCount-1 IfLCase((i,1))="ccbs"Then .Cells(iTindex,1)=iTindex-1 .Cells(iTindex,2)=(i,2) .Cells(iTindex,3)=(i,3) .Cells(iTindex,9)="E" s=(i,4) .Cells(iTindex,10)=s'(i,4) .Cells(iTindex,13)="depend" 'IfiTindex=270ThenStop iTindex=iTindex+1 EndIf Next EndWith IfiDupCount>0ThenMsgBox"有"&iDupCount&"个重复的逻辑JOB!",vbInformation ExitSub Errh: MsgBox"请在Cycle配置文档下执行此宏!",vbInformation ' EndSub '公共函数：使用oracle数据库前执行检查，是否存在ODBC数据源adt2b，如没有引导用户添加 'CTYPE 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'JOBTYPE 'JOBTYPE 'SOURCE_TABLE 'CTYPE .Cells(iTindex,12)=(i,4)'LDM_TABLE '.Cells(iTindex,14)=(i,5)'BZ .Cells(iTindex,4)="ccbs"'(i,1) '如已有或成功添加后打开并返回connection '''''''''''''''''''''''''''''''''''''''''''''''''' FunctionOpenOraDSN(OptionaldsnAsString="adt2b")AsConnection DimiRetAsLong,sDriverAsString,sConnAsString DimsServerAsString,sUserAsString,sPassAsString DimcAsConnection OnErrorGoToErrh sDriver="MicrosoftODBCforOracle" sConn="DSN="&dsn IfSQLConfigDataSource(vbAPINull,ODBC_CONFIG_SYS_DSN,sDriver,sConn)=0Then MsgBox"没有创建名为"&dsn&"的数据源！"&vbCrLf&"点确定后将会引导你创建.(需要先安装 oracle客户端，并配置好到数据库服务器的连接)",vbInformation sServer=InputBox("例如:odsptcs","请输入Oracle配置的连接服务名","odsptcs") IfsServer=""ThenEnd sUser=InputBox("例如:adt2b","请输入Oracle用户名","adt2b") IfsUser=""ThenEnd sPass=InputBox("例如:adt2b","请输入Oracle用户的密码","adt2b") IfsPass=""ThenEnd sConn=sConn&Chr(0)&"SERVER="&sServer&Chr(0)&"UID="&sUser&Chr(0)& "PWD="&sPass iRet=SQLConfigDataSource(vbAPINull,ODBC_ADD_SYS_DSN,sDriver,sConn) IfiRetThen SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass MsgBox"数据源DSN创建成功！",vbInformation Else MsgBox"数据源DSN创建失败！",vbExclamation End EndIf Else sUser=GetSetting(APPNAME,"DSN",dsn&".UID") sPass=GetSetting(APPNAME,"DSN",dsn&".PWD") DoWhilesUser="" sUser=InputBox("","请输入Oracle用户名","adt2b") Loop DoWhilesPass="" sPass=InputBox("","请输入Oracle用户的密码","adt2b") Loop SaveSettingAPPNAME,"DSN",dsn&".UID",sUser SaveSettingAPPNAME,"DSN",dsn&".PWD",sPass EndIf Setc=NewConnection "DSN="&dsn,sUser,sPass SetOpenOraDSN=c ExitFunction Errh: ption,vbCritical,"打开数据库失败" End EndFunction ------------------------------------------- OptionExplicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ' ' ' Job参数导入辅助工具V1.0 2007.4.12V0.1 2007.4.12V0.2 2007.4.13V1.0参数信息替换使用正则表达式规则,且规则可配置,从而增加了可扩展性 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' DimshtAsWorksheet Dimsh5AsWorksheet'信息登记(集成侧试) Dimsh7AsWorksheet'规则配置 '文件参数规则非文件参数规则 DimParaRule0()AsString,ParaRule1()AsString,JobList()AsString DimJobAsString,SourceAsString,sAddAsString,TargetAsString DimfFilterAsBoolean'是否执行过滤，只保留集成测试sheet中的Job DimmodiBlankAsInteger'集成测试的空行 Sub读取Job导出的xml文件填充参数() 'OnErrorGoToErrh DimsFileAsString,iAsInteger Setsht=FindParaSheet IfshtIsNothingThen MsgBox"不存在单元测试Job参数登记的表单!",vbExclamation End EndIf Setsh5=FindParaSheet("信息登记(集成测试)") Setsh7=FindParaSheet("参数宏自动提取配置") ReadParaRule sFile=nFilename("xmlFile(*.xml),*.xml",,"请选择Job导出的xml文件") IfsFile="False"ThenEnd i=FindBlankLine(sht) Ifi>3OrmodiBlank>4Then IfMsgBox("是否先清掉以前的单元测试参数和集成测试参数?",vbQuestionOrvbYesNo)=vbYes Then Ifi>3Then ("$A$3:$Z$"&i).Delete i=3 EndIf IfmodiBlank>4Then ("$A$4:$Z$"&modiBlank).Delete modiBlank=4 EndIf EndIf EndIf ("$A$"&i&":$Z$"&i).Select fFilter=(("B1").Value="1") ReadParasFile ExitSub Errh: ption,vbCritical EndSub PrivateSubReadParaRule() DimiAsInteger,jAsInteger,iiAsInteger DimiCount0AsInteger,iCount1AsInteger DimsAsString j=FindBlankLine(sh7,"B",1) 'ReDimParaRule(1,12,0) Fori=3Toj-1 s=Trim(("$D$"&i).Value) Ifs="0"Then ReDimPreserveParaRule0(12,iCount0) Forii=0To8 ParaRule0(ii,iCount0)=("$"&Chr(Asc("C")+ii)&"$"&i).Value Next iCount0=iCount0+1 ElseIfs="1"Then ReDimPreserveParaRule1(12,iCount1) Forii=0To8 ParaRule1(ii,iCount1)=("$"&Chr(Asc("C")+ii)&"$"&i).Value Next iCount1=iCount1+1 EndIf Next j=FindBlankLine(sh5) modiBlank=j IffFilterThen j=j-5 Ifj<0Then fFilter=False ExitSub EndIf ReDimJobList(j) Fori=0Toj JobList(i)=("$A$"&(i+4)).Value Next EndIf EndSub '找到最后空行并选定 '参数:1.要查找的表单 100)AsInteger 'OnErrorResumeNext DimiAsInteger,iStepAsInteger iStep=Step Do i=i+iStep ("$"&a&"$"&i).Value=""Then IfiStep=1Then '("$A$"&i&":$Z$"&i).Select FindBlankLine=i ExitFunction EndIf i=i-iStep iStep=iStep2 EndIf Loop EndFunction '寻找"参数登记(单元测试)"表单,增加模块通用性 FunctionFindParaSheet(OptionalFindNameAsString="参数登记(单元测试)",OptionalWbNameAs String="")AsWorksheet DimwbAsWorkbook,shAsWorksheet WorkbookIsNothingThen IfWbName=""OrInStr(,WbName)Then '先在当前Workbook中寻找 IfInStr(,FindName)Then SetFindParaSheet=sh ' ExitFunction EndIf Next 2.字符标识的列 FunctionFindBlankLine(shtAsWorksheet,OptionalaAsString="A",OptionalStepAsInteger= EndIf EndIf '然后在所有Workbook中寻找 ForEachwbInWorkbooks IfInStr(,WbName)Then eets IfInStr(,FindName)Then SetFindParaSheet=sh ExitFunction EndIf Next EndIf Next EndFunction '寻找某一workbook FunctionFindWorkbook(FindstrAsString)AsWorkbook DimwbAsWorkbook ForEachwbInWorkbooks IfInStr(,Findstr)Then SetFindWorkbook=wb ExitFunction EndIf Next EndFunction FunctionReadPara(FileAsString) DimdomDocAsDOMDocument DimolAsIXMLDOMNodeList,oeAsIXMLDOMElement DimiAsInteger,iColorAsInteger DimPara()AsString,Names()AsString SetdomDoc=NewDOMDocument WithdomDoc .async=False (File)Then Setol=.childNodes(1).childNodes iColor=36 i=Mid(s,4,InStr(s,":")-4) IfRange("$A$"&i-1).ndex=iColorTheniColor=37 OnErrorGoToForErrh ForEachoeInol me="Job"Then DimlAsIXMLDOMNodeList DimsNameAsString,sHelpTxtAsString,iParamTypeAsInteger,iIndexAsInteger Job=ribute("Identifier") IffFilterThenIfInArr(Job,JobList)=0ThenGoToNextJob Setl= SingleNode("Record[@Identifier='ROOT']/Collection[@Name='Parameters']").childNodes Then iIndex=0 ReDimPara(12,0) Fori= sName=l(i-1).selectSingleNode("Property[@Name='Name']").Text sHelpTxt="" iParamType=0 OnErrorResumeNext 'sHelpTxt=l(i-1).selectSingleNode("Property[@Name='HelpTxt']").Text iParamType=l(i- 1).selectSingleNode("Property[@Name='ParamType']").Text OnErrorGoToForErrh IfLeft(sName,1)<>"$"Then'若为继承的环境变量，则忽略 ReDimPreservePara(12,iIndex) Para(0,iIndex)=sName Para(1,iIndex)=IIf(iParamType=4,0,1) Para(3,iIndex)=sHelpTxt iIndex=iIndex+1 EndIf Next 'IfsJob="f_dep_td_pdbpdb_ccbs_bldm_phy"ThenStop Names=Split(Job,"_") Target="" IfArrInited(Names)Then IfUBound(Names)>1Then IfNames(0)="init"Then Target=Names(2) Else Target=Names(1) EndIf Target=UCase(Target) EndIf EndIf AnalyzeParaPara Fori=0ToUBound(Para,2) SetFormat WithSelection .="TimesNewRoman" .=12 IfPara(3,i)=""Then .ndex=0 Else .ndex=iColor EndIf .Range("A1")=Job .Range("B1").Value=i+1 DimjAsInteger IfPara(3,i)="输出文件"ThenPara(5,i)=UCase(Para(5,i)) Forj=0To9 .Range(Chr(Asc("C")+j)&"1").Value=Para(j,i) Next .Range("A2:Z2").Select EndWith Next iColor=iColor+1 IfiColor=40TheniColor=36 EndIf Withsh5 .Cells(modiBlank,1)=Job .Cells(modiBlank,2)="" .Cells(modiBlank,3)=Source .Cells(modiBlank,4)="N" .Cells(modiBlank,5)="ODSB" .Cells(modiBlank,6)="0" .Cells(modiBlank,8)="D" .Cells(modiBlank,9)=Job EndWith modiBlank=modiBlank+1 EndIf GoToNextJob ForErrh: NextJob: Else MsgBox"载入XML文件失败！",vbExclamation SetdomDoc=Nothing End EndIf EndWith te EndFunction IfMsgBox("添加Job:"&Job&"参数失败！"&vbCrLf&"错误信息:"&Error&vbCrLf& Next "是否继续其它Job?",vbCriticalOrvbYesNo)=vbNoThenExitFor PrivateSubSetFormat() DimiAsInteger Fori=1To16 WithSelection(1,i).Borders(xlEdgeLeft) .LineStyle=xlContinuous .Weight=xlThin .ColorIndex=xlAutomatic EndWith WithSelection(1,i).Borders(xlEdgeTop) .LineStyle=xlContinuous .Weight=xlThin .ColorIndex=xlAutomatic EndWith WithSelection(1,i).Borders(xlEdgeBottom) .LineStyle=xlContinuous .Weight=xlThin .ColorIndex=xlAutomatic EndWith WithSelection(1,i).Borders(xlEdgeRight) .LineStyle=xlContinuous .Weight=xlThin .ColorIndex=xlAutomatic EndWith Next EndSub FunctionReplaceVar(ssAsString,smAsSubMatches)AsString DimiAsInteger,sAsString s=ss IfInStr(s,"{")Then s=Replace(s,"{S}",Source) s=Replace(s,"{A}",sAdd) s=Replace(s,"{T}",Target) EndIf IfInStr(s,"$")Then Fori= s=Replace(s,"$"&i,sm(i-1)) Next EndIf Ifs="all"Ors="add"Thens=UCase(s) ReplaceVar=s EndFunction PrivateSubAnalyzePara(Para()AsString) DimiAsInteger,Names(),iiAsInteger,sAsString,myArr()AsString,jjAsInteger DimSourceTableAsString,TargetAsString,TargetTables()AsString DimcoAsCollection,jAsInteger 'OnErrorResumeNext ReDimNames(0) Source="":sAdd="" Fori=0ToUBound(Para,2) IfPara(1,i)=0Then ReDimPreserveNames(ii) Names(ii)=Split(Para(0,i),"_") ii=ii+1 EndIf Next DimArr()AsString IfNotIsEmpty(Names(0))Then ReDimArr(UBound(Names)) Fori=0ToUBound(Arr) Arr(i)=Names(i)(0) Next Source=MaxArr(Arr) ii=0 Fori=0ToUBound(Names) IfUBound(Names(i))=2Then ReDimPreserveArr(ii) Arr(ii)=Names(i)(1) ii=ii+1 EndIf Next IfiiThen SourceTable=MaxArr(Arr) IfSourceTable<>""Then Fori=0ToUBound(Para,2) IfPara(1,i)=0Then IfPara(0,i)=Source&"_"&SourceTable&"_add"Then sAdd="ADD" ExitFor ElseIfPara(0,i)=Source&"_"&SourceTable&"_all"Then sAdd="ALL" EndIf EndIf Next EndIf EndIf EndIf DimregpAsNewRegExp DimmcAsMatchCollection,smAsSubMatches Case=True Source=UCase(Source) OnLocalErrorResumeNext Fori=0ToUBound(Para,2) s=Para(0,i) IfPara(1,i)=0Then Forii=0ToUBound(ParaRule0,2) n="^"&Replace(ParaRule0(0,ii),"{S}",Source)&"$" Setmc=e(s) Then IfMsgBox("正则表达式匹配失败！"&vbCrLf&"源字符串:"&s&vbCrLf&"规则:"& ParaRule0(0,ii)&vbCrLf_ &"请查看设定的规则是否有误？"&vbCrLf&"是否取消此条规则？",vbExclamationOr vbYesNo)=vbYesThen Forj=iiToUBound(ParaRule0,2)-1 Forjj=0ToUBound(ParaRule0,1) ParaRule0(jj,j)=ParaRule0(jj,j+1) Next Next ReDimPreserveParaRule0(12,j-1) EndIf EndIf =1Then Setsm=mc(0).SubMatches Forj=0To6 Para(j+2,i)=ReplaceVar(ParaRule0(j+2,ii),sm) Next Setmc=Nothing Setsm=Nothing ExitFor EndIf Setmc=Nothing Next Else Forii=0ToUBound(ParaRule1,2) n="^"&Replace(ParaRule1(0,ii),"{S}",Source)&"$" Setmc=e(s) Then IfMsgBox("正则表达式匹配失败！"&vbCrLf&"源字符串:"&s&vbCrLf&"规则:"& ParaRule1(0,ii)&vbCrLf_ &"请查看设定的规则是否有误？"&vbCrLf&"是否取消此条规则？",vbExclamationOr vbYesNo)=vbYesThen Forj=iiToUBound(ParaRule1,2)-1 Forjj=0ToUBound(ParaRule1,1) ParaRule1(jj,j)=ParaRule1(jj,j+1) Next Next ReDimPreserveParaRule1(12,j-1) EndIf EndIf =1Then Setsm=mc(0).SubMatches Para(3,i)=ReplaceVar(ParaRule1(3,ii),sm) ExitFor EndIf Next Para(9,i)="#"&Para(0,i)&"#" EndIf Next EndSub FunctionMaxArr(Arr()AsString)AsString DimiAsInteger,jAsInteger,iMaxAsInteger DimUniqArr()AsString,CountArr()AsInteger ReDimUniqArr(0) ReDimCountArr(0) UniqArr(0)=Arr(0) Fori=1ToUBound(Arr) j=InArr(Arr(i),UniqArr) Ifj>0Then CountArr(j-1)=CountArr(j-1)+1 Else ReDimPreserveUniqArr(UBound(UniqArr())+1) ReDimPreserveCountArr(UBound(UniqArr())) UniqArr(UBound(UniqArr()))=Arr(i) EndIf Next Fori=0ToUBound(UniqArr) IfCountArr(i)>iMaxThen iMax=CountArr(i) j=i EndIf Next MaxArr=UniqArr(j) EndFunction FunctionInArr(sAsString,Arr()AsString)AsInteger DimiAsInteger InArr=0 Fori=0ToUBound(Arr) Ifs=Arr(i)Then InArr=i+1 ExitFor EndIf Next EndFunction FunctionArrInited(Arr()AsString)AsBoolean OnErrorResumeNext DimiAsInteger i=UBound(Arr) ArrInited=(=0) EndFunction ----------------------------------------------------- Subgen_jobinfo() DimseqId seqId=InputBox("请输入SequenceID(唯一标识开发人员的三位ID)","生成文件") file_name=eAsFilename("jobinfo_"+seqId+".cfg","cfgFile(*.cfg),*.cfg") Iffile_name="False"Then ExitSub EndIf filenum=FreeFile Openfile_nameForOutputAs#filenum i=4 j=4 start=4 oneRow="" Post=0 totalRowCount=0 DoWhileTrim(Sheets("-JOB信息登记(集成测试)").Cells(j,1))<>"" totalRowCount=totalRowCount+1 j=j+1 Loop DoWhileTrim(Sheets("-JOB信息登记(集成测试)").Cells(i,1))<>"" j=1 Count=0 DoWhilej<=18 oneCol=Trim(Sheets("-JOB信息登记(集成测试)").Cells(i,j)) '对job描述字段长度进行限制，取前80个字符 Ifj=2Then Forn=1ToLen(oneCol) currChar=Asc(Mid(oneCol,n,1)) IfcurrChar>0AndcurrChar<255Then Count=Count+1 Else Count=Count+2 EndIf IfCount=80Then oneCol=Mid(oneCol,1,n) ExitFor ElseIfCount>80Then oneCol=Mid(oneCol,1,n-1) ExitFor EndIf Nextn EndIf Ifj=1Then oneCol=LCase(oneCol) EndIf Ifj=3Then oneCol=LCase(oneCol) EndIf oneRow=oneRow+oneCol+"|" j=j+1 Loop '去除回车换行符 oneRow=Replace(oneRow,Chr$(13),"") oneRow=Replace(oneRow,Chr$(10),"") i=i+1 '最后一行只包含换行 Ifstart+totalRowCount=iThen oneRow=oneRow+Chr$(10) Print#filenum,oneRow; Else Print#filenum,oneRow EndIf oneRow="" Loop Close#filenum MsgBox"文件保存成功" EndSub --------------------------------------------------- Subgen_jobparm() DimseqId seqId=InputBox("请输入SequenceID(唯一标识开发人员的三位ID)","生成jobparm文件") file_name=eAsFilename("jobparm_"+seqId+".cfg","cfgFile(*.cfg),*.cfg") Iffile_name="False"Then ExitSub EndIf filenum=FreeFile Openfile_nameForOutputAs#filenum i=4 j=4 start=4 totalRowCount=0 oneRow="" DoWhileTrim(Sheets("-JOB参数登记(单元测试)").Cells(j,1))<>"" totalRowCount=totalRowCount+1 j=j+1 Loop DoWhileTrim(Sheets("-JOB参数登记(单元测试)").Cells(i,1))<>"" j=1 DoWhilej<=13 oneCol=Trim(Sheets("-JOB参数登记(单元测试)").Cells(i,j)) Ifj=7Then oneCol=LCase(oneCol) EndIf Ifj=8Then oneCol=LCase(oneCol) EndIf oneRow=oneRow+oneCol+"|" j=j+1 Loop '去除回车换行符 oneRow=Replace(oneRow,Chr$(13),"") oneRow=Replace(oneRow,Chr$(10),"") i=i+1 '最后一行只包含换行 Ifstart+totalRowCount=iThen oneRow=oneRow+Chr$(10) Print#filenum,oneRow; Else Print#filenum,oneRow EndIf oneRow="" Loop Close#filenum MsgBox"文件保存成功" EndSub --------------------------------------------------- FunctionIsSheetExist(wbAsWorkbook,strAsString)AsBoolean OnErrorResumeNext Setx=(str) IfErr=0Then IsSheetExist=True Else IsSheetExist=False EndIf EndFunction FunctionIsWorkbookExist(fileStrAsVariant)AsBoolean oks IfInStr(1,fileStr,,vbTextCompare)>1Then flag=True EndIf Nextwb IfflagThen IsWorkbookExist=True Else IsWorkbookExist=False EndIf EndFunction FunctionNewWorkbook(wsCountAsInteger)AsWorkbook DimOriginalWorksheetCountAsLong SetNewWorkbook=Nothing IfwsCount<1OrwsCount>255ThenExitFunction OriginalWorksheetCount=InNewWorkbook InNewWorkbook=wsCount SetNewWorkbook= InNewWorkbook=OriginalWorksheetCount EndFunction Subgen_all() yAlerts=False Updating=False DimFilenamesAsVariant Dimsave_name DimstrAsString DimseqId start=4 j=4 i=4 jobInfoCols=18 jobParmCols=13 jobInfoRowNum=0 jobParmRowNum=0 sumJobInfo=4 sumJobParm=4 infoOneRow="" parmOneRow="" Filenames=nFilename("Excel文件(*.xls),*.xls",,"选择文件",,True) IfNotIsArray(Filenames)Then MsgBox"没有选定文件" ExitSub EndIf DimArr()AsString Setdictionary=CreateObject("nary") Form=1ToUBound(Filenames) IfNotIsWorkbookExist(Filenames(m))Then lenames(m) Else oks IfInStr(1,Filenames(m),,vbTextCompare)>1Then te EndIf Nextwb EndIf IfNotIsSheetExist(ActiveWorkbook,"-JOB信息登记(集成测试)")Then MsgBoxFilenames(m)+"中不存在-JOB信息登记(集成测试)" ExitSub EndIf IfNotIsSheetExist(ActiveWorkbook,"-JOB参数登记(单元测试)")Then MsgBoxFilenames(m)+"中不存在-JOB参数登记(单元测试)" ExitSub EndIf SetcurrJobInfo=("-JOB信息登记(集成测试)") SetcurrJobParm=("-JOB参数登记(单元测试)") j=4 DoWhileTrim((j,1))<>"" jobInfoRowNum=jobInfoRowNum+1 j=j+1 Loop j=4 DoWhileTrim((j,1))<>"" jobParmRowNum=jobParmRowNum+1 j=j+1 Loop Nextm seqId=InputBox("请输入SequenceID(唯一标识开发人员的三位ID)","生成文件") IfseqId="False"Then ExitSub EndIf jobInfo_name=eAsFilename("jobinfo_"+seqId+".cfg","cfg File(*.cfg),*.cfg") IfjobInfo_name="False"Then ExitSub EndIf jobInfo=FreeFile OpenjobInfo_nameForOutputAs#jobInfo ForfileIdx=1ToUBound(Filenames) oks IfInStr(1,Filenames(fileIdx),,vbTextCompare)>1Then te EndIf Nextwb SetcurrJobInfo=("-JOB信息登记(集成测试)") i=4 DoWhileTrim((i,1))<>"" j=1 Count=0 DoWhilej<=jobInfoCols oneCol=Trim((i,j)) '对job描述字段长度进行限制，取前80个字符 Ifj=2Then Forn=1ToLen(oneCol) currChar=Asc(Mid(oneCol,n,1)) IfcurrChar>0AndcurrChar<255Then Count=Count+1 Else Count=Count+2 EndIf IfCount=80Then oneCol=Mid(oneCol,1,n) ExitFor ElseIfCount>80Then oneCol=Mid(oneCol,1,n-1) ExitFor EndIf Nextn EndIf Ifj=1Then oneCol=LCase(oneCol) EndIf Ifj=3Then oneCol=LCase(oneCol) EndIf infoOneRow=infoOneRow+oneCol+"|" j=j+1 Loop '去除回车换行符 infoOneRow=Replace(infoOneRow,Chr$(13),"") infoOneRow=Replace(infoOneRow,Chr$(10),"") i=i+1 sumJobInfo=sumJobInfo+1 '最后一行只包含换行 Ifstart+jobInfoRowNum=sumJobInfoThen infoOneRow=infoOneRow+Chr$(10) Print#jobInfo,infoOneRow; Else Print#jobInfo,infoOneRow EndIf infoOneRow="" Loop NextfileIdx Close#jobInfo jobParm_name=eAsFilename("jobparm_"+seqId+".cfg","cfg File(*.cfg),*.cfg") IfjobParm_name="False"Then ExitSub EndIf jobParm=FreeFile OpenjobParm_nameForOutputAs#jobParm Forfilenum=1ToUBound(Filenames) oks IfInStr(1,Filenames(filenum),,vbTextCompare)>1Then te EndIf Nextwb SetcurrJobParm=("-JOB参数登记(单元测试)") i=4 DoWhileTrim(Sheets("-JOB参数登记(单元测试)").Cells(i,1))<>"" j=1 DoWhilej<=jobParmCols oneCol=Trim((i,j)) Ifj=7Then oneCol=LCase(oneCol) EndIf Ifj=8Then oneCol=LCase(oneCol) EndIf parmOneRow=parmOneRow+oneCol+"|" j=j+1 Loop '去除回车换行符 parmOneRow=Replace(parmOneRow,Chr$(13),"") parmOneRow=Replace(parmOneRow,Chr$(10),"") i=i+1 sumJobParm=sumJobParm+1 '最后一行只包含换行 Ifstart+jobParmRowNum=sumJobParmThen parmOneRow=parmOneRow+Chr$(10) Print#jobParm,parmOneRow; Else Print#jobParm,parmOneRow EndIf parmOneRow="" Loop Nextfilenum Close#jobParm fName=eAsFilename("gen_","ExcelFile(*.xls),*.xls") IffName="False"Then ExitSub EndIf 'DimwbAsWorkbook Setwb=NewWorkbook(4) 'eets(1).Name="-JOB变量定义" eets(1).name="-文件属性" eets(2).name="-JOB需求映射信息(物理设计前)" eets(3).name="-JOB参数登记(单元测试)" eets(4).name="-JOB信息登记(集成测试)" Forfilenum=1ToUBound(Filenames) oks IfInStr(1,Filenames(filenum),,vbTextCompare)>1Then te EndIf Nextwbs SetjobInfoReg=("-JOB信息登记(集成测试)") SetjobParReg=("-JOB参数登记(单元测试)") SetjobVar=("-JOB变量定义") SetfilePro=("-文件属性") SetjobReqMap=("-JOB需求映射信息(物理设计前)") Iffilenum=1Then eets(1) Forrownum1= (rownum1,1)<>""Then (rownum1).eets(5).Rows(rownum1) EndIf Nextrownum1 Forrownum2= (rownum2,1)<>""Then (rownum2).eets(4).Rows(rownum2) EndIf Nextrownum2 Forrownum3= (rownum3).eets(2).Rows(rownum3) Nextrownum3 Forrownum4= (rownum4,1)<>""Then (rownum4).eets(3).Rows(rownum4) EndIf Nextrownum4 Else Forrownum1= (rownum1,1)<>""Then (rownum1).Copy eets(5).Rows(eets(5).+1) EndIf Nextrownum1 Forrownum2= (rownum2,1)<>""Then (rownum2).Copy eets(4).Rows(eets(4).+1) EndIf Nextrownum2 Forrownum3= (rownum3,1)<>""Then (rownum3).Copy eets(3).Rows(eets(3).+1) EndIf Nextrownum3 EndIf Nextfilenum Fori=1To5 eets(i). .name="宋体" .Size="12" EndWith Nexti fName alse Setwb=Nothing SetjobInfoReg=Nothing SetjobParReg=Nothing SetjobReqMap=Nothing SetfilePro=Nothing SetjobVar=Nothing MsgBox"文件保存成功" yAlerts=True Updating=True EndSub
本文发布于:2024-09-14 01:56:18，感谢您对本站的认可！
本文链接：https://www.4u4v.net/it/1726250178386613.html
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系，我们将在24小时内删除。
| 留言与评论（共有 0 条评论） |
