excel中vba技术应用

本文由zdgg99贡献
doc文档可能在WAP端浏览体验不佳。建议您优先选择TXT，或下载源文件到本机查看。
excel 中 vba 技术应用
[示例 04-01]增加工作表(Add 方法) Sub AddWorksheet() MsgBox "在当前工作簿中添加一个工作表" Worksheets.Add MsgBox "在当前工作簿中的工作表 sheet2 之前添加一个工作表" Worksheets.Add before:=Worksheets("sheet2") MsgBox "在当前工作簿中的工作表 sheet2 之后添加一个工作表" Worksheets.Add after:=Worksheets("sheet2") MsgBox "在当前工作簿中添加 3 个工作表" Worksheets.Add Count:=3 End Sub 示例说明：Add 方法带有 4 个可选的参数，其中参数 Before 和参数 After 指定所增加的工作表的位置， 但两个参数只能选一；参数 Count 用来指定增加的工作表数目。 [示例 04-02]复制工作表(Copy 方法) Sub CopyWorksheet() MsgBox "在当前工作簿中复制工作表 sheet1 并将所复制的工作表放在工作表 sheet2 之前" Worksheets("sheet1").Copy Before:=Worksheets("sheet2") MsgBox "在当前工作簿中复制工作表 sheet2 并将所复制的工作表放在工作表 sheet3 之后" Worksheets("sheet2").Copy After:=Worksheets("sheet3") End Sub 示例说明：Copy 方法带有 2 个可选的参数，即参数 Before 和参数 After，在使用时两个参数只参选一。 [示例 04-03]移动工作表(Move 方法) Sub MoveWorksheet() MsgBox "在当前工作簿中将工作表 sheet3 移至工作表 sheet2 之前" Worksheets("sheet3").Move Before:=Worksheets("sheet2") MsgBox "在当前工作簿中将工作表 sheet1 移至最后" Worksheets("sheet1").Move After:=Worksheets(Worksheets.Count) End Sub 示例说明：Move 方法与 Copy 方法的参数相同，作用也一样。 [示例 04-04]隐藏和显示工作表(Visible 属性) [示例 04-04-01] Sub testHide() 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 End Sub 示例说明：本示例演示了隐藏和显示工作表的各种情形。其中，使用 xlSheetVeryHidden 常量来隐藏工 作表，将不能通过选择工作表菜单栏中的“格式”——“工作表”——“取消隐藏”命令来取消隐藏。 [示例 04-04-02] Sub ShowAllSheets() MsgBox "使当前工作簿

中的所有工作表都显示(即将隐藏的工作表也显示)" Dim ws As Worksheet For Each ws In Sheets ws.Visible = True Next ws End Sub [示例 04-05]获取工作表数(Count 属性) [示例 04-05-01] Sub WorksheetNum() Dim i As Long i = Worksheets.Count MsgBox "当前工作簿的工作表数为：" & Chr(10) & i End Sub [示例 04-05-02] Sub WorksheetNum() Dim i As Long i = Sheets.Count MsgBox "当前工作簿的工作表数为：" & Chr(10) & i End Sub 示例说明： 在一个包含图表工作表的工作簿中运行上述两段代码， 将会得出不同的结果， 原因是对于 Sheets 集合来讲，工作表包含图表工作表。应注意 Worksheets 集合与 Sheets 集合的区别，下同。 [示例 04-06]获取或设置工作表名称(Name 属性)
[示例 04-06-01] Sub NameWorksheet() Dim sName As String, sChangeName As String sName = Worksheets(2).Name MsgBox "当前工作簿中第 2 个工作表的名字为：" & sName sChangeName = "我的工作表" MsgBox "将当前工作簿中的第 3 个工作表名改为：" & sChangeName Worksheets(3).Name = sChangeName End Sub 示例说明：使用 Name 属性可以获取指定工作表的名称，也可以设置工作表的名称。 [示例 04-06-02]重命名工作表 Sub ReNameSheet() Dim xStr As String Retry: Err.Clear xStr = InputBox("请输入工作表的新名称:" _ , "重命名工作表", https://www.doczj.com/doc/5115394826.html,) If xStr = "" Then Exit Sub On Error Resume Next https://www.doczj.com/doc/5115394826.html, = xStr If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description Err.Clear GoTo Retry End If On Error GoTo 0 '…… End Sub [示例 04-07]激活/选择工作表(Activate 方法和 Select 方法) [示例 04-07-01] Sub SelectWorksheet() MsgBox "激活当前工作簿中的工作表 sheet2" Worksheets("sheet2").Activate MsgBox "激活当前工作簿中的工作表 sheet3" Worksheets("sheet3").Select MsgBox "同时选择工作簿中的工作表 sheet2 和 sheet3" Worksheets(Array("sheet2", "sheet3")).Select End Sub 示例说明：Activate 方法只能激活一个工作表，而 Select 方法可以同时选择多个工作表。 [示例 04-07-02] Sub SelectManySheet() MsgBox "选取第一个和第三个工作表."
Worksheets(1).Select Worksheets(3).Select False End Sub [示例 04-08]获取当前工作表的索引号(Index 属性) Sub GetSheetIndex() Dim i As Long i = ActiveSheet.Index MsgBox "您正使用的工作表索引号为" & i End Sub [示例 04-09]选取前一个工作表(Previous 属性) Sub PreviousSheet() If ActiveSheet.Index <> 1 Then MsgBox "选取当前工作簿中当前工作表的前一个工作表" ActiveSheet.Previous.Activate Else MsgBox "已到第一个工作表" End If End Sub 示例说明：如果当前工作表是第一个工作表，则使用 Previous 属性会出错。 [示例 04-10]选取下一个工作表(Next 属性) Sub NextSheet() If ActiveSheet.Index <> Worksheets.Count Then MsgBox "选取当前工作簿中当前工作表的下一个工作表" ActiveSheet.Next.Activa

te Else MsgBox “已到最后一个工作表” End If End Sub 示例说明：如果当前工作表是最后一个工作表，则使用 Next 属性会出错。 [示例 04-11]工作表行和列的操作 [示例 04-11-01]隐藏行 Sub HideRow() Dim iRow As Long MsgBox "隐藏当前单元格所在的行" iRow = ActiveCell.Row ActiveSheet.Rows(iRow).Hidden = True MsgBox "取消隐藏" ActiveSheet.Rows(iRow).Hidden = False End Sub
[示例 04-11-02]隐藏列 Sub HideColumn() Dim iColumn As Long MsgBox "隐藏当前单元格所在列" iColumn = ActiveCell.Column ActiveSheet.Columns(iColumn).Hidden = True MsgBox "取消隐藏" ActiveSheet.Columns(iColumn).Hidden = False End Sub [示例 04-11-03]插入行 Sub InsertRow() Dim rRow As Long MsgBox "在当前单元格上方插入一行" rRow = Selection.Row ActiveSheet.Rows(rRow).Insert End Sub [示例 04-11-04]插入列 Sub InsertColumn() Dim cColumn As Long MsgBox "在当前单元格所在行的左边插入一行" cColumn = Selection.Column ActiveSheet.Columns(cColumn).Insert End Sub [示例 04-11-05]插入多行 Sub InsertManyRow() MsgBox "在当前单元格所在行上方插入三行" Dim rRow As Long, i As Long For i = 1 To 3 rRow = Selection.Row ActiveSheet.Rows(rRow).Insert Next i End Sub [示例 04-11-06]设置行高 Sub SetRowHeight() MsgBox "将当前单元格所在的行高设置为 25" Dim rRow As Long, iRow As Long rRow = ActiveCell.Row iRow = ActiveSheet.Rows(rRow).RowHeight ActiveSheet.Rows(rRow).RowHeight = 25 MsgBox "恢复到原来的行高"
ActiveSheet.Rows(rRow).RowHeight = iRow End Sub [示例 04-11-07]设置列宽 Sub SetColumnWidth() MsgBox "将当前单元格所在列的列宽设置为 20" Dim cColumn As Long, iColumn As Long cColumn = ActiveCell.Column iColumn = ActiveSheet.Columns(cColumn).ColumnWidth ActiveSheet.Columns(cColumn).ColumnWidth = 20 MsgBox "恢复至原来的列宽" ActiveSheet.Columns(cColumn).ColumnWidth = iColumn End Sub [示例 04-11-08]恢复行高列宽至标准值 Sub ReSetRowHeightAndColumnWidth() MsgBox "将当前单元格所在的行高和列宽恢复为标准值" https://www.doczj.com/doc/5115394826.html,eStandardHeight = True https://www.doczj.com/doc/5115394826.html,eStandardWidth = True End Sub [示例 04-12]工作表标签 [示例 04-12-01] 设置工作表标签的颜色 Sub SetSheetTabColor() MsgBox "设置当前工作表标签的颜色" ActiveSheet.Tab.ColorIndex = 7 End Sub [示例 04-12-01]恢复工作表标签颜色 Sub SetSheetTabColorDefault() MsgBox "将当前工作表标签颜色设置为默认值" ActiveSheet.Tab.ColorIndex = -4142 End Sub [示例 04-12-03]交替隐藏或显示工作表标签 Sub HideOrShowSheetTab() MsgBox "隐藏/显示工作表标签" ActiveWindow.DisplayWorkbookTabs = Not ActiveWindow.DisplayWorkbookTabs End Sub Sub PageCount() Dim i As Long i = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1) MsgBox "当前工作表共" & i & "页."
End Sub [示例 04-14]保护/撤销保护工作表 [示例 04-14-01] Sub ProtectSheet() MsgBox "保护当前

工作表并设定密码" ActiveSheet.Protect Password:="fanjy" End Sub 示例说明：运行代码后，当前工作表中将不允许编辑，除非撤销工作表保护。 [示例 04-14-02] Sub UnprotectSheet() MsgBox "撤销当前工作表保护" ActiveSheet.Unprotect End Sub 示例说明：运行代码后，如果原保护的工作表设置有密码，则要求输入密码。 [示例 04-14-03]保护当前工作簿中的所有工作表 Sub ProtectAllWorkSheets() On Error Resume Next Dim ws As Worksheet Dim myPassword As String myPassword = InputBox("请输入您的密码" & vbCrLf & _ "(不输入表明无密码)" & vbCrLf & vbCrLf & _ "确保您没有忘记密码！", "输入密码") For Each ws In ThisWorkbook.Worksheets ws.Protect (myPassword) Next ws End Sub [示例 04-14-04]撤销对当前工作簿中所有工作表的保护 Sub UnprotectAllWorkSheets() On Error Resume Next Dim ws As Worksheet Dim myPassword As String myPassword = InputBox("请输入您的密码" & vbCrLf & _ "(不输入表示无密码)", "输入密码") For Each ws In ThisWorkbook.Worksheets ws.Unprotect (myPassword) Next ws End Sub [示例 04-14-05]仅能编辑未锁定的单元格 Sub OnlyEditUnlockedCells()
Sheets("Sheet1").EnableSelection = xlUnlockedCells ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub 示例说明：运行本代码后，在当前工作表中将只能对未锁定的单元格进行编辑，而其它单元格将不能编辑。 未锁定的单元格是指在选择菜单“格式——单元格”命令后所弹出的对话框中的“保护”选项卡中，未选中“锁 定”复选框的单元格或单元格区域。 [示例 04-15]删除工作表(Delete 方法) Sub DeleteWorksheet() MsgBox "删除当前工作簿中的工作表 sheet2" Application.DisplayAlerts = False Worksheets("sheet2").Delete Application.DisplayAlerts = True End Sub 示例说明：本示例代码使用 Application.DisplayAlerts = False 来屏蔽弹出的警告框。 <一些编程方法和技巧> [示例 04-16] 判断一个工作表(名)是否存在 [示例 04-16-01] Sub testWorksheetExists1() Dim ws As Worksheet If Not WorksheetExists(ThisWorkbook, "sheet1") Then MsgBox "不能够找到该工作表", vbOKOnly Exit Sub End If MsgBox "已经找到工作表" Set ws = ThisWorkbook.Worksheets("sheet1") End Sub '- - - - - - - - - - - - - - - - - - Function WorksheetExists(wb As Workbook, sName As String) As Boolean Dim s As String On Error GoTo ErrHandle s = wb.Worksheets(sName).Name WorksheetExists = True Exit Function ErrHandle: WorksheetExists = False End Function 示例说明：在测试代码中，用相应的工作簿名和工作表名分别代替“ThisWorkbook”和“Sheet1”，来判断 指定工作表是否在工作簿中存在。 [示例 04-16-02] Sub testWorksheetExists2() If Not SheetExists("<工作表名>") Then
MsgBox "<工作表名> 不存在!" Else Sheets("<工作表名>").Activate End If End Sub '- - - - - - - - - - - - - -

- - - - Function SheetExists(SheetName As String) As Boolean SheetExists = False On Error GoTo NoSuchSheet If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True Exit Function End If NoSuchSheet: End Function 示例说明：在代码中，用实际工作表名代替<>。 [示例 04-16-03] Sub TestingFunction() '如果工作表存在则返回 True，否则为 False '测试 DoesWksExist1 函数 Debug.Print DoesWksExist1("Sheet1") Debug.Print DoesWksExist1("Sheet100") Debug.Print "" '测试 DoesWksExist2 函数 Debug.Print DoesWksExist2("Sheet1") Debug.Print DoesWksExist2("Sheet100") End Sub ‘- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Function DoesWksExist1(sWksName As String) As Boolean Dim i As Long For i = Worksheets.Count To 1 Step -1 If Sheets(i).Name = sWksName Then Exit For End If Next If i = 0 Then DoesWksExist1 = False Else DoesWksExist1 = True End If End Function ‘- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Function DoesWksExist2(sWksName As String) As Boolean
Dim wkb As Worksheet On Error Resume Next Set wkb = Sheets(sWksName) On Error GoTo 0 DoesWksExist2 = IIf(Not wkb Is Nothing, True, False) End Function [示例 04-17]排序工作表 [示例 04-17-01] Sub SortWorksheets1() Dim bSorted As Boolean Dim nSortedSheets As Long Dim nSheets As Long Dim n As Long nSheets = Worksheets.Count nSortedSheets = 0 Do While (nSortedSheets < nSheets) And Not bSorted bSorted = True nSortedSheets = nSortedSheets + 1 For n = 1 To nSheets - nSortedSheets If StrComp(Worksheets(n).Name, Worksheets(n + 1).Name, vbTextCompare) > 0 Then Worksheets(n + 1).Move Before:=Worksheets(n) bSorted = False End If Next n Loop End Sub 示例说明：本示例代码采用了冒泡法排序。 [示例 04-17-02] Sub SortWorksheets2() '根据字母对工作表排序 Dim i As Long, j As Long For i = 1 To Sheets.Count For j = 1 To Sheets.Count - 1 If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then Sheets(j).Move After:=Sheets(j + 1) End If Next j Next i End Sub [示例 04-17-03] Sub SortWorksheets3()
'以升序排列工作表 Dim sCount As Integer, i As Integer, j As Integer Application.ScreenUpdating = False sCount = Worksheets.Count If sCount = 1 Then Exit Sub For i = 1 To sCount - 1 For j = i + 1 To sCount If Worksheets(j).Name < Worksheets(i).Name Then Worksheets(j).Move Before:=Worksheets(i) End If Next j Next i End Sub 示例说明：若想排序所有工作表，将代码中的 Worksheets 替换为 Sheets。 [示例 04-18]删除当前工作簿中的空工作表 Sub Delete_EmptySheets() Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets If Application.WorksheetFunction.CountA(sh.Cells) = 0 Then Application.DisplayAlerts = False sh.Delete Application.DisplayAlerts = True End If Next End Sub 以下是些同事们编写的 vba 宏，贴出来供参考 Option Explicit ''''''''''''''''''''''''''''''' 'CCB?先进数通?联想利泰?崔铂 ''''''''''''''''''''''''''''''' Public Const APPNAME = "CuiBo_VBA_Tools" P

rivate Const ODBC_ADD_DSN = 1 ' Add data source Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source Private Const ODBC_REMOVE_DSN = 3 ' Remove data source Private Const ODBC_ADD_SYS_DSN = 4 ' Add data source Private Const ODBC_CONFIG_SYS_DSN = 5 ' Configure (edit) data source Private Const ODBC_REMOVE_SYS_DSN = 6 ' Remove data source Private Const vbAPINull As Long = 0& ' NULL Pointer Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As
Long Sub 根据字段级映射关系生成数据库 Comment 语句() Dim sh As Worksheet, sFile As String, s As String Dim c As Collection, iNum As Integer Dim iFieldCount As Integer, iLineCount As Integer, i As Integer Dim sTbInfo As String, sFieldInfo As String, sTable As String, sField As String Set sh = FindParaSheet("映射关系", "字段级映射关系") If sh Is Nothing Then MsgBox "找不到字段级映射关系表单,请打开相应文件!", vbInformation Exit Sub End If 'MsgBox sh.Range("$N$4").Row & "," & sh.Range("$N$4").Column s = https://www.doczj.com/doc/5115394826.html, s = Left(s, Len(s) - 4) & ".sql" sFile = Application.GetSaveAsFilename(s, "(*.sql),*.sql", , "请选择将要生成的 sql 文件的保 存位置") If sFile = "False" Then Exit Sub iNum = FreeFile Open sFile For Output As #iNum Set c = New Collection i=4 On Local Error Resume Next With sh Do sTable = .Cells(i, 14) sField = .Cells(i, 17) If sField = "" Or sTable = "" Then Exit Do sFieldInfo = .Cells(i, 18) If sTable <> c(sTable) Then sTbInfo = .Cells(i, 13) c.Add sTable, sTable Print #iNum, "comment on table " & sTable & " is '" & sTbInfo & " ';" iLineCount = iLineCount + 1 End If Print #iNum, "comment on column " & sTable & "." & sField & " is '" & sFieldInfo; "';" iFieldCount = iFieldCount + 1 iLineCount = iLineCount + 1 i=i+1 Loop End With Close MsgBox "成功写入" & c.Count & "个表、" & iFieldCount & "个字段的 Comment 语句，共" & iLineCount & "行" & vbCrLf & "到文件:" & sFile Set c = Nothing
Set sh = Nothing End Sub Sub 参数入 Oracle 临时表() Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer, iBlank2 As Integer Dim sh4 As Worksheet, sh5 As Worksheet On Error GoTo Errh Set sh4 = FindParaSheet() Set sh5 = FindParaSheet("信息登记(集成测试)") If sh4 Is Nothing Or sh5 Is Nothing Then MsgBox "不存在 Job 参数登记的表单!", vbExclamation End End If 'sh4 和 sh5 对应表但 iBlank1 = FindBlankLine(sh4) iBlank2 = FindBlankLine(sh5) If iBlank1 <= 3 And iBlank2 <= 4 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName) ' dsn user password
Set conn = OpenOraDSN("adt2b") 'conn.Open "adt2b", "adt2b", "adt2b" If conn.Execute("select count(*) from ds_t_job j,ds_t_jobparam p where j.jobname=p.jobname")(0) > 0 Then i

= MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from ds_t_job") conn.Execute ("delete from ds_t_jobparam") ElseIf i = VbMsgBoxResult.vbCancel Then conn.Close Set conn = Nothing Exit Sub End If End If conn.BeginTrans For i = 4 To iBlank2 - 1 With sh5 s = "insert into ds_t_job values('" & .Cells(i, 1) For j = 2 To 9 s = s & "','" & .Cells(i, j) Next
s = s & "')" conn.Execute (s) End With Next For i = 3 To iBlank1 - 1 With sh4 s = "insert into ds_t_jobparam values('" & .Cells(i, 1) For j = 2 To 13 s = s & "','" & .Cells(i, j) Next s = s & "')" conn.Execute (s) End With Next https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 3 & " 条记录到参数表！" & vbCrLf _ & "成功插入 " & iBlank2 - 4 & " 条记录到 Job 表！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub Sub Cycle 配置入 Oracle 临时表(Optional sh As Worksheet = Nothing) Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer On Error GoTo Errh If sh Is Nothing Then Set sh = ActiveWorkbook.Sheets("临时表") End If iBlank1 = FindBlankLine(sh) If iBlank1 <= 2 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName)
'
dsn
user
password
Set conn = OpenOraDSN("adt2b") conn.BeginTrans If conn.Execute("select count(*) from ds_t_cycle")(0) > 0 Then i = MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from DS_T_CYCLE") ElseIf i = VbMsgBoxResult.vbCancel Then conn.RollbackTrans conn.Close Set conn = Nothing Exit Sub End If End If For i = 2 To iBlank1 - 1 With sh s = "insert into DS_T_CYCLE values('" & .Cells(i, 2) For j = 3 To 14 s = s & "','" & .Cells(i, j) Next s = s & "')" 'MsgBox s conn.Execute (s) End With Next 'conn.Execute ("delete from depend_cfg d where exists (select * from ds_t_cycle where jobname=d.job_name)") 'conn.Execute ("insert into depend_cfg select distinct sou_sys,jobname,description,spcjob from ds_t_cycle where cytype='depend'") https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 2 & " 条记录到临时表 DS_T_Cycle！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub
'只在某一 workbook 中寻找包含 name 的 sheet Function FindSheet(wb As Workbook, sName As String) As Worksheet Dim sh As Worksheet For Each sh In wb.Sheets If InStr(https://www.doczj.com/doc/5115394826.html,, sName) Then Set FindSheet = sh Exit For End If Next End Function Sub Cycle 配置组合为临时表() Dim wb As Workbook Dim sh21 As Worksheet, sh24 As Worksheet, sh

25 As Worksheet, sh3 As Worksheet Dim sht As Worksheet, i As Integer, iCount As Integer, iTindex As Integer Dim Jobs() As String, sJob As String, iJobIndex As Integer, iDupCount As Integer On Error GoTo Errh Set wb = Application.ActiveWorkbook Set sh21 = wb.Sheets("2.1 公共作业配置－增量合并全量") Set sh24 = FindSheet(wb, "2.4 公共作业配置-T-1 机构") Set sh25 = FindSheet(wb, "2.5 公共作业配置-FDM 全量库 ECIF 客户号更新") Set sh3 = wb.Sheets("3.作业依赖关系") On Error Resume Next Set sht = wb.Worksheets("临时表") If sht Is Nothing Then Sheet9.Copy sh3 Set sht = ActiveSheet sht.Visible = xlSheetVisible With Sheet9 Set .sh = sht Set .CmdBox2 = sht.OLEObjects(1).Object End With End If i = FindBlankLine(sht, "B", 1) If i > 2 Then sht.Range("$A$3:$Z$" & i).Delete End If '''''''''提取四个表内容 iTindex = 2 With sht '2.1 公共作业配置－增量合并全量 iCount = FindBlankLine(sh21, "B") iJobIndex = 0 For i = 3 To iCount - 1
If LCase(sh21.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh21.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 3) = sh21.Cells(i, 3) .Cells(iTindex, 4) = "ccbs" 'INDEX 'JOBNAME 'DESC .Cells(iTindex, 2) = sJob 'sh21.Cells(i, 2) 'SOU_SYS
.Cells(iTindex, 5) = sh21.Cells(i, 11) 'BRANCH .Cells(iTindex, 6) = sh21.Cells(i, 10) 'YWLX .Cells(iTindex, 7) = sh21.Cells(i, 13) 'YXPD .Cells(iTindex, 8) = sh21.Cells(i, 14) 'YXJ .Cells(iTindex, 9) = "E" 'SOURCE_TABLE .Cells(iTindex, 12) = sh21.Cells(i, 6) 'LDM_TABLE .Cells(iTindex, 13) = "add2all" iJobIndex = iJobIndex + 1 iTindex = iTindex + 1 End If Next '2.4 公共作业配置-T-1 机构拆并 iCount = FindBlankLine(sh24, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh24.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh24.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh24.Cells(i, 2) .Cells(iTindex, 3) = sh24.Cells(i, 3) .Cells(iTindex, 4) = "ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex, 14) = sh21.Cells(i, 12) 'BZ 'JOBTYPE .Cells(iTindex, 11) = Replace(Replace(sh21.Cells(i, 5), vbCrLf, "/"), vbLf, "/")
'SOU_SYS
.Cells(iTindex, 5) = sh24.Cells(i, 7) 'BRANCH .Cells(iTindex, 6) = sh24.Cells(i, 6) 'YWLX
.Cells(iTindex, 7) = sh24.Cells(i, 8) 'YXPD .Cells(iTindex, 8) = sh24.Cells(i, 9) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "orgmerg" iTindex = iTindex + 1 End If Next 'FDM 全量库 ECIF 客户号更新 iCount = FindBlankLine(sh25, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh25.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh25.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iD

upCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh25.Cells(i, 2) .Cells(iTindex, 3) = sh25.Cells(i, 3) .Cells(iTindex, 4) = sh25.Cells(i, 1) .Cells(iTindex, 6) = "ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh24.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh24.Cells(i, 5) 'BZ
.Cells(iTindex, 5) = sh25.Cells(i, 5) 'BRANCH .Cells(iTindex, 7) = sh25.Cells(i, 6) 'YXPD .Cells(iTindex, 8) = sh25.Cells(i, 7) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "ecifacc" iTindex = iTindex + 1 End If Next '3.作业依赖关系 iCount = FindBlankLine(sh3, "B") Dim s As String For i = 2 To iCount - 1 If LCase(sh3.Cells(i, 1)) = "ccbs" Then .Cells(iTindex, 1) = iTindex - 1 'INDEX 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh25.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh25.Cells(i, 5) 'BZ
.Cells(iTindex, 2) = sh3.Cells(i, 2) .Cells(iTindex, 3) = sh3.Cells(i, 3) .Cells(iTindex, 9) = "E" s = sh3.Cells(i, 4)
'JOBNAME 'DESC 'SOU_SYS 'JOBTYPE
.Cells(iTindex, 4) = "ccbs" 'sh3.Cells(i, 1)
.Cells(iTindex, 10) = s ' sh3.Cells(i, 4) .Cells(iTindex, 13) = "depend" 'If iTindex = 270 Then Stop iTindex = iTindex + 1 End If Next End With If iDupCount > 0 Then MsgBox "有 " & iDupCount & " 个重复的逻辑 JOB!", vbInformation Exit Sub Errh: MsgBox "请在 Cycle 配置文档下执行此宏!", vbInformation 'MsgBox https://www.doczj.com/doc/5115394826.html, End Sub '公共函数：使用 oracle 数据库前执行检查，是否存在 ODBC 数据源 adt2b，如没有引导用户添加 ' 如已有或成功添加后打开并返回 connection 'CTYPE
'''''''''''''''''''''''''''''''''''''''''''''''''' Function OpenOraDSN(Optional dsn As String = "adt2b") As Connection Dim iRet As Long, sDriver As String, sConn As String Dim sServer As String, sUser As String, sPass As String Dim c As Connection On Error GoTo Errh sDriver = "Microsoft ODBC for Oracle" sConn = "DSN=" & dsn If SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, sDriver, sConn) = 0 Then MsgBox "没有创建名为" & dsn & "的数据源！" & vbCrLf & "点确定后将会引导你创建.(需要先 安装 oracle 客户端，并配置好到数据库服务器的连接)", vbInformation sServer = InputBox("例如:odsptcs", "请输入 Oracle 配置的连接服务名", "odsptcs") If sServer = "" Then End sUser = InputBox("例如:adt2b", "请输入 Oracle 用户名", "adt2b") If sUser = "" Then End sPass = InputBox("例如:adt2b", "请输入 Oracle 用户的密码", "adt2b") If sPass = "" Then End sConn = sConn & Chr(0) & "SERVER=" & sServer & Chr(0) & "UID=" & sUser & Chr(0) & "PWD=" & sPass iRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, sDriver, sConn) If iRet Then SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass MsgBox "数据源 DSN 创建成功！

", vbInformation
Else MsgBox "数据源 DSN 创建失败！", vbExclamation End End If Else sUser = GetSetting(APPNAME, "DSN", dsn & ".UID") sPass = GetSetting(APPNAME, "DSN", dsn & ".PWD") Do While sUser = "" sUser = InputBox("", "请输入 Oracle 用户名", "adt2b") Loop Do While sPass = "" sPass = InputBox("", "请输入 Oracle 用户的密码", "adt2b") Loop SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass End If Set c = New Connection c.Open "DSN=" & dsn, sUser, sPass Set OpenOraDSN = c Exit Function Errh: MsgBox Err.Description, vbCritical, "打开数据库失败" End End Function Option Explicit ''''''''''''''''''''''''''''''' Public Const APPNAME = "CuiBo_VBA_Tools" Private Const ODBC_ADD_DSN = 1 ' Add data source Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source Private Const ODBC_REMOVE_DSN = 3 ' Remove data source Private Const ODBC_ADD_SYS_DSN = 4 ' Add data source Private Const ODBC_CONFIG_SYS_DSN = 5 ' Configure (edit) data source Private Const ODBC_REMOVE_SYS_DSN = 6 ' Remove data source Private Const vbAPINull As Long = 0& ' NULL Pointer Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long Sub 根据字段级映射关系生成数据库 Comment 语句() Dim sh As Worksheet, sFile As String, s As String Dim c As Collection, iNum As Integer Dim iFieldCount As Integer, iLineCount As Integer, i As Integer Dim sTbInfo As String, sFieldInfo As String, sTable As String, sField As String Set sh = FindParaSheet("映射关系", "字段级映射关系")
If sh Is Nothing Then MsgBox "找不到字段级映射关系表单,请打开相应文件!", vbInformation Exit Sub End If 'MsgBox sh.Range("$N$4").Row & "," & sh.Range("$N$4").Column s = https://www.doczj.com/doc/5115394826.html, s = Left(s, Len(s) - 4) & ".sql" sFile = Application.GetSaveAsFilename(s, "(*.sql),*.sql", , "请选择将要生成的 sql 文件的保 存位置") If sFile = "False" Then Exit Sub iNum = FreeFile Open sFile For Output As #iNum Set c = New Collection i=4 On Local Error Resume Next With sh Do sTable = .Cells(i, 14) sField = .Cells(i, 17) If sField = "" Or sTable = "" Then Exit Do sFieldInfo = .Cells(i, 18) If sTable <> c(sTable) Then sTbInfo = .Cells(i, 13) c.Add sTable, sTable Print #iNum, "comment on table " & sTable & " is '" & sTbInfo & " ';" iLineCount = iLineCount + 1 End If Print #iNum, "comment on column " & sTable & "." & sField & " is '" & sFieldInfo; "';" iFieldCount = iFieldCount + 1 iLineCount = iLineCount + 1 i=i+1 Loop End With Close MsgBox "成功写入" & c.Count & "个表、" & iFieldCount & "个字段的 Comment 语句，共" & iLineCount & "行" & vbCrLf & "到文件:" & sFile Set c = Nothing Set sh = Nothing End Sub Sub 参数入 Oracle 临时表() Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer, iBlank2 As Integer Dim sh4 As Worksheet

, sh5 As Worksheet
On Error GoTo Errh Set sh4 = FindParaSheet() Set sh5 = FindParaSheet("信息登记(集成测试)") If sh4 Is Nothing Or sh5 Is Nothing Then MsgBox "不存在 Job 参数登记的表单!", vbExclamation End End If 'sh4 和 sh5 对应表但 iBlank1 = FindBlankLine(sh4) iBlank2 = FindBlankLine(sh5) If iBlank1 <= 3 And iBlank2 <= 4 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName) ' dsn user password
Set conn = OpenOraDSN("adt2b") 'conn.Open "adt2b", "adt2b", "adt2b" If conn.Execute("select count(*) from ds_t_job j,ds_t_jobparam p where j.jobname=p.jobname")(0) > 0 Then i = MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from ds_t_job") conn.Execute ("delete from ds_t_jobparam") ElseIf i = VbMsgBoxResult.vbCancel Then conn.Close Set conn = Nothing Exit Sub End If End If conn.BeginTrans For i = 4 To iBlank2 - 1 With sh5 s = "insert into ds_t_job values('" & .Cells(i, 1) For j = 2 To 9 s = s & "','" & .Cells(i, j) Next s = s & "')" conn.Execute (s) End With Next For i = 3 To iBlank1 - 1 With sh4 s = "insert into ds_t_jobparam values('" & .Cells(i, 1)
For j = 2 To 13 s = s & "','" & .Cells(i, j) Next s = s & "')" conn.Execute (s) End With Next https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 3 & " 条记录到参数表！" & vbCrLf _ & "成功插入 " & iBlank2 - 4 & " 条记录到 Job 表！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub Sub Cycle 配置入 Oracle 临时表(Optional sh As Worksheet = Nothing) Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer On Error GoTo Errh If sh Is Nothing Then Set sh = ActiveWorkbook.Sheets("临时表") End If iBlank1 = FindBlankLine(sh) If iBlank1 <= 2 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName) ' dsn user password
Set conn = OpenOraDSN("adt2b") conn.BeginTrans If conn.Execute("select count(*) from ds_t_cycle")(0) > 0 Then i = MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from DS_T_CYCLE")
ElseIf i = VbMsgBoxResult.vbCancel Then conn.RollbackTrans conn.Close Set conn = Nothing Exit Sub End If End If For i = 2 To iBlank1 - 1 With sh s = "insert into DS_T_CYCLE values('" & .Cells(i, 2) For j = 3 To 14 s = s & "','" & .Cells(i, j) Next s = s & "')" 'MsgBox s conn.Execute (s) End With Next 'conn.Execute ("delete from depend_cfg d where exists (select * from ds_t_cycle where jobname=d.job_name)") 'conn.Execute ("insert into depend_cfg select distinct sou_sys,jobname,d

escription,spcjob from ds_t_cycle where cytype='depend'") https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 2 & " 条记录到临时表 DS_T_Cycle！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub '只在某一 workbook 中寻找包含 name 的 sheet Function FindSheet(wb As Workbook, sName As String) As Worksheet Dim sh As Worksheet For Each sh In wb.Sheets If InStr(https://www.doczj.com/doc/5115394826.html,, sName) Then Set FindSheet = sh Exit For
End If Next End Function Sub Cycle 配置组合为临时表() Dim wb As Workbook Dim sh21 As Worksheet, sh24 As Worksheet, sh25 As Worksheet, sh3 As Worksheet Dim sht As Worksheet, i As Integer, iCount As Integer, iTindex As Integer Dim Jobs() As String, sJob As String, iJobIndex As Integer, iDupCount As Integer On Error GoTo Errh Set wb = Application.ActiveWorkbook Set sh21 = wb.Sheets("2.1 公共作业配置－增量合并全量") Set sh24 = FindSheet(wb, "2.4 公共作业配置-T-1 机构") Set sh25 = FindSheet(wb, "2.5 公共作业配置-FDM 全量库 ECIF 客户号更新") Set sh3 = wb.Sheets("3.作业依赖关系") On Error Resume Next Set sht = wb.Worksheets("临时表") If sht Is Nothing Then Sheet9.Copy sh3 Set sht = ActiveSheet sht.Visible = xlSheetVisible With Sheet9 Set .sh = sht Set .CmdBox2 = sht.OLEObjects(1).Object End With End If i = FindBlankLine(sht, "B", 1) If i > 2 Then sht.Range("$A$3:$Z$" & i).Delete End If '''''''''提取四个表内容 iTindex = 2 With sht '2.1 公共作业配置－增量合并全量 iCount = FindBlankLine(sh21, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh21.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh21.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If
Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 3) = sh21.Cells(i, 3) .Cells(iTindex, 4) = "ccbs" 'INDEX 'JOBNAME 'DESC .Cells(iTindex, 2) = sJob 'sh21.Cells(i, 2) 'SOU_SYS
.Cells(iTindex, 5) = sh21.Cells(i, 11) 'BRANCH .Cells(iTindex, 6) = sh21.Cells(i, 10) 'YWLX .Cells(iTindex, 7) = sh21.Cells(i, 13) 'YXPD .Cells(iTindex, 8) = sh21.Cells(i, 14) 'YXJ .Cells(iTindex, 9) = "E" 'SOURCE_TABLE .Cells(iTindex, 12) = sh21.Cells(i, 6) 'LDM_TABLE .Cells(iTindex, 13) = "add2all" iJobIndex = iJobIndex + 1 iTindex = iTindex + 1 End If Next '2.4 公共作业配置-T-1 机构拆并 iCount = FindBlankLine(sh24, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh24.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh24.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh24.Cells(i, 2) .Cells(iTindex, 3) = sh24.Cells(i, 3) .Cells(iTindex, 4) = "

ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex, 14) = sh21.Cells(i, 12) 'BZ 'JOBTYPE .Cells(iTindex, 11) = Replace(Replace(sh21.Cells(i, 5), vbCrLf, "/"), vbLf, "/")
'SOU_SYS
.Cells(iTindex, 5) = sh24.Cells(i, 7) 'BRANCH .Cells(iTindex, 6) = sh24.Cells(i, 6) 'YWLX .Cells(iTindex, 7) = sh24.Cells(i, 8) 'YXPD .Cells(iTindex, 8) = sh24.Cells(i, 9) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "orgmerg" 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh24.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh24.Cells(i, 5) 'BZ
iTindex = iTindex + 1 End If Next 'FDM 全量库 ECIF 客户号更新 iCount = FindBlankLine(sh25, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh25.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh25.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh25.Cells(i, 2) .Cells(iTindex, 3) = sh25.Cells(i, 3) .Cells(iTindex, 4) = sh25.Cells(i, 1) .Cells(iTindex, 6) = "ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX
.Cells(iTindex, 5) = sh25.Cells(i, 5) 'BRANCH .Cells(iTindex, 7) = sh25.Cells(i, 6) 'YXPD .Cells(iTindex, 8) = sh25.Cells(i, 7) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "ecifacc" iTindex = iTindex + 1 End If Next '3.作业依赖关系 iCount = FindBlankLine(sh3, "B") Dim s As String For i = 2 To iCount - 1 If LCase(sh3.Cells(i, 1)) = "ccbs" Then .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh3.Cells(i, 2) .Cells(iTindex, 3) = sh3.Cells(i, 3) .Cells(iTindex, 9) = "E" s = sh3.Cells(i, 4) .Cells(iTindex,10) = s ' sh3.Cells(i, 4) .Cells(iTindex, 13) = "depend" 'CTYPE 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'JOBTYPE 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh25.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh25.Cells(i, 5) 'BZ
.Cells(iTindex, 4) = "ccbs" 'sh3.Cells(i, 1)
'If iTindex = 270 Then Stop iTindex = iTindex + 1 End If Next End With If iDupCount > 0 Then MsgBox "有 " & iDupCount & " 个重复的逻辑 JOB!", vbInformation Exit Sub Errh: MsgBox "请在 Cycle 配置文档下执行此宏!", vbInformation 'MsgBox https://www.doczj.com/doc/5115394826.html, End Sub '公共函数：使用 oracle 数据库前执行检查，是否存在 ODBC 数据源 adt2b，如没有引导用户添加 ' 如已有或成功添加后打开并返回 connection
'''''''''''''''''''''''''''''''''''''''''''''''''' Function OpenOraDSN(Optional dsn As String = "adt2b") As Connection Dim iRet As Long, sDriver As String, sConn As String Dim sServer As String, sUser As String, sPass As String Dim c As Connection On Error GoTo Errh sDriver = "Microsoft ODBC for Oracle" sConn = "DSN=" & dsn If SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, sDriver, sConn) = 0 Then MsgBox "没有创建名为" & dsn & "的数据源！" & vbCrLf & "点确定后将会引导你创建.(需要先 安

装 oracle 客户端，并配置好到数据库服务器的连接)", vbInformation sServer = InputBox("例如:odsptcs", "请输入 Oracle 配置的连接服务名", "odsptcs") If sServer = "" Then End sUser = InputBox("例如:adt2b", "请输入 Oracle 用户名", "adt2b") If sUser = "" Then End sPass = InputBox("例如:adt2b", "请输入 Oracle 用户的密码", "adt2b") If sPass = "" Then End sConn = sConn & Chr(0) & "SERVER=" & sServer & Chr(0) & "UID=" & sUser & Chr(0) & "PWD=" & sPass iRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, sDriver, sConn) If iRet Then SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass MsgBox "数据源 DSN 创建成功！", vbInformation Else MsgBox "数据源 DSN 创建失败！", vbExclamation End End If Else sUser = GetSetting(APPNAME, "DSN", dsn & ".UID") sPass = GetSetting(APPNAME, "DSN", dsn & ".PWD")
Do While sUser = "" sUser = InputBox("", "请输入 Oracle 用户名", "adt2b") Loop Do While sPass = "" sPass = InputBox("", "请输入 Oracle 用户的密码", "adt2b") Loop SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass End If Set c = New Connection c.Open "DSN=" & dsn, sUser, sPass Set OpenOraDSN = c Exit Function Errh: MsgBox Err.Description, vbCritical, "打开数据库失败" End End Function Option Explicit ''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''' Public Const APPNAME = "CuiBo_VBA_Tools" Private Const ODBC_ADD_DSN = 1 ' Add data source Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source Private Const ODBC_REMOVE_DSN = 3 ' Remove data source Private Const ODBC_ADD_SYS_DSN = 4 ' Add data source Private Const ODBC_CONFIG_SYS_DSN = 5 ' Configure (edit) data source Private Const ODBC_REMOVE_SYS_DSN = 6 ' Remove data source Private Const vbAPINull As Long = 0& ' NULL Pointer Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long Sub 根据字段级映射关系生成数据库 Comment 语句() Dim sh As Worksheet, sFile As String, s As String Dim c As Collection, iNum As Integer Dim iFieldCount As Integer, iLineCount As Integer, i As Integer Dim sTbInfo As String, sFieldInfo As String, sTable As String, sField As String Set sh = FindParaSheet("映射关系", "字段级映射关系") If sh Is Nothing Then MsgBox "找不到字段级映射关系表单,请打开相应文件!", vbInformation Exit Sub End If 'MsgBox sh.Range("$N$4").Row & "," & sh.Range("$N$4").Column s = https://www.doczj.com/doc/5115394826.html,
s = Left(s, Len(s) - 4) & ".sql" sFile = Application.GetSaveAsFilename(s, "(*.sql),*.sql", , "请选择将要生成的 sql 文件的保 存位置") If sFile = "False" Then Exit Sub iNum = FreeFile Open sFile For Output As #iNum Set c = New Collection i=4 On Local Error Resume Next With sh Do sTable = .Cells(i, 14) sField = .Cells(i, 17) If sField = "" Or sTable = "" T

hen Exit Do sFieldInfo = .Cells(i, 18) If sTable <> c(sTable) Then sTbInfo = .Cells(i, 13) c.Add sTable, sTable Print #iNum, "comment on table " & sTable & " is '" & sTbInfo & " ';" iLineCount = iLineCount + 1 End If Print #iNum, "comment on column " & sTable & "." & sField & " is '" & sFieldInfo; "';" iFieldCount = iFieldCount + 1 iLineCount = iLineCount + 1 i=i+1 Loop End With Close MsgBox "成功写入" & c.Count & "个表、" & iFieldCount & "个字段的 Comment 语句，共" & iLineCount & "行" & vbCrLf & "到文件:" & sFile Set c = Nothing Set sh = Nothing End Sub Sub 参数入 Oracle 临时表() Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer, iBlank2 As Integer Dim sh4 As Worksheet, sh5 As Worksheet On Error GoTo Errh Set sh4 = FindParaSheet() Set sh5 = FindParaSheet("信息登记(集成测试)") If sh4 Is Nothing Or sh5 Is Nothing Then MsgBox "不存在 Job 参数登记的表单!", vbExclamation End
End If 'sh4 和 sh5 对应表但 iBlank1 = FindBlankLine(sh4) iBlank2 = FindBlankLine(sh5) If iBlank1 <= 3 And iBlank2 <= 4 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName) ' dsn user password
Set conn = OpenOraDSN("adt2b") 'conn.Open "adt2b", "adt2b", "adt2b" If conn.Execute("select count(*) from ds_t_job j,ds_t_jobparam p where j.jobname=p.jobname")(0) > 0 Then i = MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from ds_t_job") conn.Execute ("delete from ds_t_jobparam") ElseIf i = VbMsgBoxResult.vbCancel Then conn.Close Set conn = Nothing Exit Sub End If End If conn.BeginTrans For i = 4 To iBlank2 - 1 With sh5 s = "insert into ds_t_job values('" & .Cells(i, 1) For j = 2 To 9 s = s & "','" & .Cells(i, j) Next s = s & "')" conn.Execute (s) End With Next For i = 3 To iBlank1 - 1 With sh4 s = "insert into ds_t_jobparam values('" & .Cells(i, 1) For j = 2 To 13 s = s & "','" & .Cells(i, j) Next s = s & "')" conn.Execute (s) End With
Next https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 3 & " 条记录到参数表！" & vbCrLf _ & "成功插入 " & iBlank2 - 4 & " 条记录到 Job 表！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub Sub Cycle 配置入 Oracle 临时表(Optional sh As Worksheet = Nothing) Dim i As Integer, j As Integer, s As String Dim conn As Connection Dim iBlank1 As Integer On Error GoTo Errh If sh Is Nothing Then Set sh = ActiveWorkbook.Sheets("临时表") End If iBlank1 = FindBlankLine(sh) If iBlank1 <= 2 Then MsgBox "没有数据需要添入表！", vbInformation Exit Sub End If '添加名为 adt2b 的 ODBC 数据源(添加时要用到 oracle 客户端配置的连接标识/ServiceName) ' dsn user pa

ssword
Set conn = OpenOraDSN("adt2b") conn.BeginTrans If conn.Execute("select count(*) from ds_t_cycle")(0) > 0 Then i = MsgBox("数据库临时表中有数据，是否删除?", vbYesNoCancel) If i = vbYes Then conn.Execute ("delete from DS_T_CYCLE") ElseIf i = VbMsgBoxResult.vbCancel Then conn.RollbackTrans conn.Close Set conn = Nothing Exit Sub End If
End If For i = 2 To iBlank1 - 1 With sh s = "insert into DS_T_CYCLE values('" & .Cells(i, 2) For j = 3 To 14 s = s & "','" & .Cells(i, j) Next s = s & "')" 'MsgBox s conn.Execute (s) End With Next 'conn.Execute ("delete from depend_cfg d where exists (select * from ds_t_cycle where jobname=d.job_name)") 'conn.Execute ("insert into depend_cfg select distinct sou_sys,jobname,description,spcjob from ds_t_cycle where cytype='depend'") https://www.doczj.com/doc/5115394826.html,mitTrans conn.Close Set conn = Nothing MsgBox "成功插入 " & iBlank1 - 2 & " 条记录到临时表 DS_T_Cycle！", vbInformation Exit Sub Errh: MsgBox Err.Description, vbCritical If Not conn Is Nothing Then If conn.State = 1 Then conn.RollbackTrans conn.Close End If Set conn = Nothing End If End Sub '只在某一 workbook 中寻找包含 name 的 sheet Function FindSheet(wb As Workbook, sName As String) As Worksheet Dim sh As Worksheet For Each sh In wb.Sheets If InStr(https://www.doczj.com/doc/5115394826.html,, sName) Then Set FindSheet = sh Exit For End If Next End Function Sub Cycle 配置组合为临时表() Dim wb As Workbook Dim sh21 As Worksheet, sh24 As Worksheet, sh25 As Worksheet, sh3 As Worksheet
Dim sht As Worksheet, i As Integer, iCount As Integer, iTindex As Integer Dim Jobs() As String, sJob As String, iJobIndex As Integer, iDupCount As Integer On Error GoTo Errh Set wb = Application.ActiveWorkbook Set sh21 = wb.Sheets("2.1 公共作业配置－增量合并全量") Set sh24 = FindSheet(wb, "2.4 公共作业配置-T-1 机构") Set sh25 = FindSheet(wb, "2.5 公共作业配置-FDM 全量库 ECIF 客户号更新") Set sh3 = wb.Sheets("3.作业依赖关系") On Error Resume Next Set sht = wb.Worksheets("临时表") If sht Is Nothing Then Sheet9.Copy sh3 Set sht = ActiveSheet sht.Visible = xlSheetVisible With Sheet9 Set .sh = sht Set .CmdBox2 = sht.OLEObjects(1).Object End With End If i = FindBlankLine(sht, "B", 1) If i > 2 Then sht.Range("$A$3:$Z$" & i).Delete End If '''''''''提取四个表内容 iTindex = 2 With sht '2.1 公共作业配置－增量合并全量 iCount = FindBlankLine(sh21, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh21.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh21.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 3) = sh21.Cells(i, 3) .Cells(iTindex, 4) = "ccbs" 'INDEX 'JOBNAME 'DESC .Cells(iTindex, 2) = sJob 'sh21.Cells(i, 2) 'SOU_SYS
.Cells(iTindex, 5) = sh21.Cells(i, 11) 'BRANCH
.Cells(iTindex, 6) = sh21.Cells(i, 10) 'YWLX .Cells(iTindex, 7) =

sh21.Cells(i, 13) 'YXPD .Cells(iTindex, 8) = sh21.Cells(i, 14) 'YXJ .Cells(iTindex, 9) = "E" 'SOURCE_TABLE .Cells(iTindex, 12) = sh21.Cells(i, 6) 'LDM_TABLE .Cells(iTindex, 13) = "add2all" iJobIndex = iJobIndex + 1 iTindex = iTindex + 1 End If Next '2.4 公共作业配置-T-1 机构拆并 iCount = FindBlankLine(sh24, "B") iJobIndex = 0 For i = 3 To iCount - 1 If LCase(sh24.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh24.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh24.Cells(i, 2) .Cells(iTindex, 3) = sh24.Cells(i, 3) .Cells(iTindex, 4) = "ccbs" 'INDEX 'JOBNAME 'DESC 'CTYPE .Cells(iTindex, 14) = sh21.Cells(i, 12) 'BZ 'JOBTYPE .Cells(iTindex, 11) = Replace(Replace(sh21.Cells(i, 5), vbCrLf, "/"), vbLf, "/")
'SOU_SYS
.Cells(iTindex, 5) = sh24.Cells(i, 7) 'BRANCH .Cells(iTindex, 6) = sh24.Cells(i, 6) 'YWLX .Cells(iTindex, 7) = sh24.Cells(i, 8) 'YXPD .Cells(iTindex, 8) = sh24.Cells(i, 9) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "orgmerg" iTindex = iTindex + 1 End If Next 'FDM 全量库 ECIF 客户号更新 iCount = FindBlankLine(sh25, "B") iJobIndex = 0 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh24.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh24.Cells(i, 5) 'BZ
For i = 3 To iCount - 1 If LCase(sh25.Cells(i, 1)) = "ccbs" Then ReDim Preserve Jobs(iJobIndex) sJob = sh25.Cells(i, 2) If InArr(sJob, Jobs) > 0 Then iDupCount = iDupCount + 1 .Range("$A$" & iTindex & ":$Z$" & iTindex).Interior.ColorIndex = 36 End If Jobs(iJobIndex) = sJob .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh25.Cells(i, 2) .Cells(iTindex, 3) = sh25.Cells(i, 3) .Cells(iTindex, 4) = sh25.Cells(i, 1) .Cells(iTindex, 6) = "ccbs" 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'YWLX
.Cells(iTindex, 5) = sh25.Cells(i, 5) 'BRANCH .Cells(iTindex, 7) = sh25.Cells(i, 6) 'YXPD .Cells(iTindex, 8) = sh25.Cells(i, 7) 'YXJ .Cells(iTindex, 9) = "E" .Cells(iTindex, 11) = "" .Cells(iTindex, 13) = "ecifacc" iTindex = iTindex + 1 End If Next '3.作业依赖关系 iCount = FindBlankLine(sh3, "B") Dim s As String For i = 2 To iCount - 1 If LCase(sh3.Cells(i, 1)) = "ccbs" Then .Cells(iTindex, 1) = iTindex - 1 .Cells(iTindex, 2) = sh3.Cells(i, 2) .Cells(iTindex, 3) = sh3.Cells(i, 3) .Cells(iTindex, 9) = "E" s = sh3.Cells(i, 4) .Cells(iTindex, 10) = s ' sh3.Cells(i, 4) .Cells(iTindex, 13) = "depend" 'If iTindex = 270 Then Stop iTindex = iTindex + 1 End If Next End With If iDupCount > 0 Then MsgBox "有 " & iDupCount & " 个重复的逻辑 JOB!", vbInformation 'CTYPE 'INDEX 'JOBNAME 'DESC 'SOU_SYS 'JOBTYPE 'JOBTYPE 'SOURCE_TABLE 'CTYPE
.Cells(iTindex, 12) = sh25.Cells(i, 4) 'LDM_TABLE '.Cells(iTindex, 14) = sh25.Cells(i, 5) 'BZ
.Cells(iTindex, 4) = "ccbs" 'sh3.Cells(i, 1)
Exit Sub Errh: MsgBox "请在 Cycle 配置文档下执行此宏!

", vbInformation 'MsgBox https://www.doczj.com/doc/5115394826.html, End Sub '公共函数：使用 oracle 数据库前执行检查，是否存在 ODBC 数据源 adt2b，如没有引导用户添加 ' 如已有或成功添加后打开并返回 connection
'''''''''''''''''''''''''''''''''''''''''''''''''' Function OpenOraDSN(Optional dsn As String = "adt2b") As Connection Dim iRet As Long, sDriver As String, sConn As String Dim sServer As String, sUser As String, sPass As String Dim c As Connection On Error GoTo Errh sDriver = "Microsoft ODBC for Oracle" sConn = "DSN=" & dsn If SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, sDriver, sConn) = 0 Then MsgBox "没有创建名为" & dsn & "的数据源！" & vbCrLf & "点确定后将会引导你创建.(需要先 安装 oracle 客户端，并配置好到数据库服务器的连接)", vbInformation sServer = InputBox("例如:odsptcs", "请输入 Oracle 配置的连接服务名", "odsptcs") If sServer = "" Then End sUser = InputBox("例如:adt2b", "请输入 Oracle 用户名", "adt2b") If sUser = "" Then End sPass = InputBox("例如:adt2b", "请输入 Oracle 用户的密码", "adt2b") If sPass = "" Then End sConn = sConn & Chr(0) & "SERVER=" & sServer & Chr(0) & "UID=" & sUser & Chr(0) & "PWD=" & sPass iRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, sDriver, sConn) If iRet Then SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass MsgBox "数据源 DSN 创建成功！", vbInformation Else MsgBox "数据源 DSN 创建失败！", vbExclamation End End If Else sUser = GetSetting(APPNAME, "DSN", dsn & ".UID") sPass = GetSetting(APPNAME, "DSN", dsn & ".PWD") Do While sUser = "" sUser = InputBox("", "请输入 Oracle 用户名", "adt2b") Loop Do While sPass = "" sPass = InputBox("", "请输入 Oracle 用户的密码", "adt2b") Loop
SaveSetting APPNAME, "DSN", dsn & ".UID", sUser SaveSetting APPNAME, "DSN", dsn & ".PWD", sPass End If Set c = New Connection c.Open "DSN=" & dsn, sUser, sPass Set OpenOraDSN = c Exit Function Errh: MsgBox Err.Description, vbCritical, "打开数据库失败" End End Function Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ' ' ' Job 参数导入辅助工具 V1.0 2007.4.12 V0.1 2007.4.12 V0.2 2007.4.13 V1.0 参数信息替换使用正则表达式规则,且规则可配置,从而增加了可扩展性
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim sht As Worksheet Dim sh5 As Worksheet '信息登记(集成侧试) Dim sh7 As Worksheet '规则配置 '文件参数规则 非文件参数规则
Dim ParaRule0() As String, ParaRule1() As String, JobList() As String Dim Job As String, Source As String, sAdd As String, Target As String Dim fFilter As Boolean '是否执行过滤，只保留集成测试 sheet 中的 Job Dim modiBlank As Integer '集成测试的空行 Sub 读取 Job 导出的 xml 文件填充参数() 'On Error GoTo Errh Dim sFile As String, i As Integer Set sht = FindParaSheet If sht Is Nothing Then MsgB

ox "不存在单元测试 Job 参数登记的表单!", vbExclamation End End If Set sh5 = FindParaSheet("信息登记(集成测试)") Set sh7 = FindParaSheet("参数宏自动提取配置")
ReadParaRule sFile = Application.GetOpenFilename("xml File(*.xml),*.xml", , "请选择 Job 导出的 xml 文 件") If sFile = "False" Then End i = FindBlankLine(sht)
If i > 3 Or modiBlank > 4 Then If MsgBox("是否先清掉以前的单元测试参数和集成测试参数?", vbQuestion Or vbYesNo) = vbYes Then If i > 3 Then sht.Range("$A$3:$Z$" & i).Delete i=3 End If If modiBlank > 4 Then sh5.Range("$A$4:$Z$" & modiBlank).Delete modiBlank = 4 End If End If End If sht.Select sht.Range("$A$" & i & ":$Z$" & i).Select fFilter = (sh7.Range("B1").Value = "1") ReadPara sFile
Exit Sub Errh: MsgBox Err.Description, vbCritical End Sub Private Sub ReadParaRule() Dim i As Integer, j As Integer, ii As Integer Dim iCount0 As Integer, iCount1 As Integer Dim s As String j = FindBlankLine(sh7, "B", 1) 'ReDim ParaRule(1, 12, 0) For i = 3 To j - 1 s = Trim(sh7.Range("$D$" & i).Value) If s = "0" Then ReDim Preserve ParaRule0(12, iCount0) For ii = 0 To 8 ParaRule0(ii, iCount0) = sh7.Range("$" & Chr(Asc("C") + ii) & "$" & i).Value Next iCount0 = iCount0 + 1 ElseIf s = "1" Then ReDim Preserve ParaRule1(12, iCount1) For ii = 0 To 8 ParaRule1(ii, iCount1) = sh7.Range("$" & Chr(Asc("C") + ii) & "$" & i).Value Next
iCount1 = iCount1 + 1 End If Next j = FindBlankLine(sh5) modiBlank = j If fFilter Then j=j-5 If j < 0 Then fFilter = False Exit Sub End If ReDim JobList(j) For i = 0 To j JobList(i) = sh5.Range("$A$" & (i + 4)).Value Next End If End Sub '找到最后空行并选定 '参数:1.要查找的表单 2.字符标识的列
Function FindBlankLine(sht As Worksheet, Optional a As String = "A", Optional Step As Integer = 100) As Integer 'On Error Resume Next Dim i As Integer, iStep As Integer iStep = Step Do i = i + iStep If sht.Range("$" & a & "$" & i).Value = "" Then If iStep = 1 Then 'sht.Range("$A$" & i & ":$Z$" & i).Select FindBlankLine = i Exit Function End If i = i - iStep iStep = iStep \ 2 End If Loop End Function '寻找"参数登记(单元测试)"表单,增加模块通用性 Function FindParaSheet(Optional FindName As String = "参数登记(单元测试)", Optional WbName As String = "") As Worksheet Dim wb As Workbook, sh As Worksheet If Not Application.ActiveWorkbook Is Nothing Then If WbName = "" Or InStr(https://www.doczj.com/doc/5115394826.html,, WbName) Then '先在当前 Workbook 中寻找
For Each sh In Application.ActiveWorkbook.Sheets If InStr(https://www.doczj.com/doc/5115394826.html,, FindName) Then Set FindParaSheet = sh 'sh.Select Exit Function End If Next End If End If '然后在所有 Workbook 中寻找 For Each wb In Workbooks If InStr(https://www.doczj.com/doc/5115394826.html,, WbName) Then For Each sh In wb.Worksheets If InStr(https://www.doczj.com/doc/5115394826.html,, FindName) Then Set FindParaSheet = sh Exit Function End If Next End If Next End Function '寻找某一 workbook Function FindWorkbook(Findstr As String) As Workbook Dim wb As Work

book For Each wb In Workbooks If InStr(https://www.doczj.com/doc/5115394826.html,, Findstr) Then Set FindWorkbook = wb Exit Function End If Next End Function Function ReadPara(File As String) Dim domDoc As DOMDocument Dim ol As IXMLDOMNodeList, oe As IXMLDOMElement Dim i As Integer, iColor As Integer Dim Para() As String, Names() As String Set domDoc = New DOMDocument With domDoc .async = False If .Load(File) Then Set ol = .childNodes(1).childNodes iColor = 36 i = Mid(Selection.Address, 4, InStr(Selection.Address, ":") - 4)
If Range("$A$" & i - 1).Interior.ColorIndex = iColor Then iColor = 37 On Error GoTo ForErrh For Each oe In ol If oe.baseName = "Job" Then Dim l As IXMLDOMNodeList Dim sName As String, sHelpTxt As String, iParamType As Integer, iIndex As Integer Job = oe.getAttribute("Identifier") If fFilter Then If InArr(Job, JobList) = 0 Then GoTo NextJob Set l = oe.selectSingleNode("Record[@Identifier='ROOT']/Collection[@Name='Parameters']").child Nodes If l.Length Then iIndex = 0 ReDim Para(12, 0) For i = 1 To l.Length sName = l(i - 1).selectSingleNode("Property[@Name='Name']").Text sHelpTxt = "" iParamType = 0 On Error Resume Next 'sHelpTxt = l(i 1).selectSingleNode("Property[@Name='HelpTxt']").Text iParamType = l(i 1).selectSingleNode("Property[@Name='ParamType']").Text On Error GoTo ForErrh If Left(sName, 1) <> "$" Then '若为继承的环境变量，则忽略 ReDim Preserve Para(12, iIndex) Para(0, iIndex) = sName Para(1, iIndex) = IIf(iParamType = 4, 0, 1) Para(3, iIndex) = sHelpTxt iIndex = iIndex + 1 End If Next 'If sJob = "f_dep_td_pdbpdb_ccbs_bldm_phy" Then Stop Names = Split(Job, "_") Target = "" If ArrInited(Names) Then If UBound(Names) > 1 Then If Names(0) = "init" Then Target = Names(2) Else
Target = Names(1) End If Target = UCase(Target) End If End If AnalyzePara Para For i = 0 To UBound(Para, 2) SetFormat With Selection https://www.doczj.com/doc/5115394826.html, = "Times New Roman" .Font.Size = 12 If Para(3, i) = "" Then .Interior.ColorIndex = 0 Else .Interior.ColorIndex = iColor End If .Range("A1") = Job .Range("B1").Value = i + 1 Dim j As Integer If Para(3, i) = "输出文件" Then Para(5, i) = UCase(Para(5, i)) For j = 0 To 9 .Range(Chr(Asc("C") + j) & "1").Value = Para(j, i) Next .Range("A2:Z2").Select End With Next iColor = iColor + 1 If iColor = 40 Then iColor = 36 End If With sh5 .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 End With modiBlank = modiBlank + 1 End If GoTo NextJob ForErrh: If MsgBox("添加 Job: " & Job & "参数失败！" & vbCrLf & "错误信息:" & Error &
vbCrLf & "是否继续其它 Job?", vbCritical Or vbYesNo) = vbNo Then Exit For NextJob: Else MsgBox "载入 XML 文件失败！", vbExclamation Set domDoc = Nothing End End If End With sht.Activate End Function Private Sub SetFormat() Dim i As Integer For i = 1 To 16 With Selection(1, i).Borders(xlEdgeLeft) .LineStyle = xlConti