一起学Excel专业开发16：使用表驱动的方法管理工作表用户接口

'定义代表接口工作簿及工作表名和预定义名称名的常量
Private Const msFILE_TIME_ENTRY As String= "PetrasTemplate.xlsx"
Private Const msRNG_NAME_LIST As String ="tblRangeNames"
Private Const msRNG_SHEET_LIST As String= "tblSheetNames"

'将用于接口设置的工作表中指定的设置值
'写入接口工作簿工作表中
Public Sub WriteSettings()
    '变量声明
    Dim rngSheet As Range
   Dim rngSheetList As Range
   Dim rngName As Range
   Dim rngNameList As Range
   Dim rngSetting As Range
   Dim sSheetTab As String
   Dim wkbBook As Workbook
   Dim wksSheet As Worksheet
   
    '关闭屏幕更新和自动计算
    '提高代码处理速度
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   
    '工时输入工作簿
   Set wkbBook = Application.Workbooks(msFILE_TIME_ENTRY)
    '设置值所在工作表的第一列
   Set rngSheetList = wksUISettings.Range(msRNG_SHEET_LIST)
    '设置值所在工作表的第一行(预定义的名称)
   Set rngNameList = wksUISettings.Range(msRNG_NAME_LIST)
   
    '遍历设置值所在工作表第一列所指的所有工作表
   For Each rngSheet In rngSheetList
        'sSheetTabName()函数将工作表代码名称
        '转换为相应的标签名称
       sSheetTab = sSheetTabName(wkbBook, rngSheet.Value)
       Set wksSheet = wkbBook.Worksheets(sSheetTab)
       
        '将设置值应用到当前工作表
        '如果设置值已存在则覆盖原设置值
       For Each rngName In rngNameList
            '设置值在工作表名所在行和预定义名所在列交叉单元格中
           Set rngSetting =Intersect(rngSheet.EntireRow, _
                                       rngName.EntireColumn)
               
            '忽略值为空的预定义名称
            If Len(rngSetting.Value) > 0Then
                wksSheet.Names.AddrngName.Value, _
                            "=" &rngSetting.Value
            End If
       Next rngName
   Next rngSheet
   
    '恢复屏幕更新和自动计算
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub

Private Function sSheetTabName(ByRefwkbProject As Workbook, _
            ByRef sCodeName As String) AsString
   Dim wksSheet As Worksheet
   For Each wksSheet In wkbProject.Worksheets
       If wksSheet.CodeName = sCodeName Then
            sSheetTabName = wksSheet.Name
            Exit For
       End If
   Next wksSheet
End Function

'从接口工作簿中读取预定义名称设置值到
'用于接口设置的工作表相应单元格中
Public Sub ReadSettings()
    '声明变量
   Dim lOffset As Long
   Dim rngName As Range
   Dim rngNameList As Range
   Dim rngSetting As Range
   Dim sMsg As String
   Dim vSetting As Variant
   Dim uAnswer As VbMsgBoxResult
   Dim wkbBook As Workbook
   Dim wksSheet As Worksheet
   
    '下面的操作不可逆
    '在清除工作表内容前提醒用户
   uAnswer = vbNo
   sMsg = "你想使用当前模板设置覆盖现有数据吗?"
   uAnswer = MsgBox(sMsg, vbQuestion + vbYesNo)
   
   If uAnswer = vbYes Then
        '关屏屏幕更新和自动计算
       Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
       
        '工时输入工作簿
       Set wkbBook = Application.Workbooks(msFILE_TIME_ENTRY)
       
        '清除自第2行起工作表已有内容
       wksUISettings.UsedRange.Offset(1, 0).Clear
   
        '赋值预定义名称区域
       wkbBook.Activate
       Set rngNameList = wksUISettings.Range(msRNG_NAME_LIST)
       
        '遍历接口工作簿工作表
       For Each wksSheet In wkbBook.Worksheets
            lOffset = lOffset + 1
           
            '将预定义名称值写入用于接口设置的工作表单元格
            With wksUISettings.Range("A1").Offset(lOffset, 0)
                '工作表代码名称
               .Value =wksSheet.CodeName
                '遍历预定义名称
                For Each rngName In rngNameList
                    '获取要写入的单元格
                    Set rngSetting =Intersect(.EntireRow, _
                                       rngName.EntireColumn)
                   
                   'setScrollArea设置需要专门处理
                    '因为它是命名区域而不是命名常量
                    If rngName.Value ="setScrollArea" Then
                        '这项设置可能不存在因此这里有错误处理
                       'On Error Resume Next.
                        On Error Resume Next
                        rngSetting.Value = _
                       wksSheet.Range("setScrollArea").Address
                        On Error GoTo 0
                    Else
                        vSetting = Empty
                        vSetting =Application.Evaluate( _
                            "'" &wksSheet.Name & "'!" & _
                            rngName.Value)
                        If NotIsError(vSetting) Then
                            rngSetting.Value =vSetting
                        End If
                    End If
                Next rngName
            End With
       Next wksSheet
   
        '恢复屏幕更新和自动计算
       ThisWorkbook.Activate
       Application.ScreenUpdating = True
       Application.Calculation = xlCalculationAutomatic
   End If
End Sub

'删除接口工作簿中的所有设置
'以便对工作簿进行维护
Public Sub RemoveSettings()
    '声明变量
   Dim wkbBook As Workbook
   Dim wksSheet As Worksheet
   
    '关闭屏幕更新和自动计算
    '加快代码的执行速度
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   
    '工时输入工作簿
   Set wkbBook = Application.Workbooks(msFILE_TIME_ENTRY)
   
    '遍历工作簿中的工作表
    '删除设置
   For Each wksSheet In wkbBook.Worksheets
       wksSheet.Unprotect
       wksSheet.Visible = xlSheetVisible
       wksSheet.Activate
       Application.ActiveWindow.DisplayHeadings = True
       wksSheet.EnableSelection = xlNoRestrictions
       wksSheet.ScrollArea = ""
        With wksSheet.UsedRange
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
       End With
   Next wksSheet
 
    '恢复屏幕更新和自动计算
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub