8.22 集成CSV导出的VBA

[vieyahn2017]

集成CSV导出的VBA

[vieyahn2017]

Sheet APE

Private Sub ListBox3_Change()
    'If ReLoad Then Exit Sub '见下方说明
    s = ""
    For i = 0 To ListBox3.ListCount - 1
       If ListBox3.Selected(i) = True Then s = s & "/" & ListBox3.List(i)
    Next
    ActiveCell = Mid(s, 2)  '去掉最前面的/

    If ActiveCell = "" Then
        ActiveCell = "请选择"
    End If

End Sub

Private Sub ListBox1_Change()
    'If ReLoad Then Exit Sub '见下方说明
    s = ""
    For i = 0 To ListBox1.ListCount - 1
       If ListBox1.Selected(i) = True Then s = s & "/" & ListBox1.List(i)
    Next
    ActiveCell = Mid(s, 2)  '去掉最前面的/

    If ActiveCell = "" Then
        ActiveCell = "请选择"
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If ActiveCell.Column = 5 Then
        If ActiveCell.Row = 15 Then
            ListBox3.Visible = False
            t = ActiveCell.Value
            'ReLoad = True '如果是根据单元格的值修改列表框，则暂时屏蔽listbox的change事件。
            With ListBox1
                For i = 0 To .ListCount - 1 '根据活动单元格内容修改列表框中被选中的内容

                    If InStr(t, .List(i)) Then
                        .Selected(i) = True
                    Else
                        .Selected(i) = False
                    End If
                Next
                'ReLoad = False
                .Top = ActiveCell.Top + ActiveCell.Height '以下语句根据活动单元格位置显示列表框
                .Left = ActiveCell.Left
                .width = ActiveCell.width
                .Visible = True
            End With
        ElseIf ActiveCell.Row = 16 Then
            ListBox1.Visible = False
            t = ActiveCell.Value
            'ReLoad = True '如果是根据单元格的值修改列表框，则暂时屏蔽listbox的change事件。
            With ListBox3
                For i = 0 To .ListCount - 1 '根据活动单元格内容修改列表框中被选中的内容

                    If InStr(t, .List(i)) Then
                        .Selected(i) = True
                    Else
                        .Selected(i) = False
                    End If
                Next
                'ReLoad = False
                .Top = ActiveCell.Top + ActiveCell.Height '以下语句根据活动单元格位置显示列表框
                .Left = ActiveCell.Left
                .width = ActiveCell.width
                .Visible = True
            End With
        Else
            ListBox1.Visible = False
            ListBox3.Visible = False

        End If

        'MsgBox g_Fun_GetSelectValues(ActiveCell, Cells(ActiveCell.Row, 2))
        'MsgBox g_Fun_GetSelectValues("车站码头/商业中心/交通干线/危险物品场所周边", "PositionType")

        Exit Sub

    End If

    ListBox1.Visible = False
    ListBox3.Visible = False

    If ActiveCell.Column = 7 And ActiveCell.Row = 1 Then  ' 新增
        InsertAPEValues
        Exit Sub
    End If

    If ActiveCell.Column = 7 And ActiveCell.Row = 2 Then  ' 重填
        result = MsgBox("确定清空已填写内容？", vbOKCancel)
        If result = vbOK Then ResetAPEValues
        Exit Sub
    End If

    If ActiveCell.Column = 8 And ActiveCell.Row = 1 Then  ' 预览
        Sheets("Data_APE").Activate
    End If

    'If ActiveCell.Column = 8 And ActiveCell.Row = 2 Then   ' 导出（在数据页面）
        'CheckValidParams
        'Exit Sub
    'End If

    '点击 是否下拉项  预留的测试功能 - 检查取值有效性
    If ActiveCell.Column = 2 And ActiveCell.Row = 2 Then
        msg = CheckValidParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

    '点击 是否必填项  预留的测试功能
    If ActiveCell.Column = 3 And ActiveCell.Row = 2 Then
        msg = CheckRequiredParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

End Sub

Public Sub ResetAPEValues()

    g_sheet_APE = Sheets("Config").Cells(5, 1).Value

    ' 清空内容 【通用部分】

    startIndex = 3
    endindex = Sheets(g_sheet_APE).UsedRange.Rows.Count
    For RowIndex = startIndex To endindex
        '第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划） 【下拉选从Config那边取值】
        keyType = Sheets(g_sheet_APE).Cells(RowIndex, 2).Value

        If keyType = 2 Then
            Sheets(g_sheet_APE).Cells(RowIndex, 5).Value = "请选择"
        Else
            Sheets(g_sheet_APE).Cells(RowIndex, 5).Value = ""
        End If
    Next

    ' 清空内容 【特殊取值】
    Sheets(g_sheet_APE).Cells(11, 5).Value = "否"

End Sub

Function CheckRequiredParams()
    ' 检查必填参数。
    ' 通过第三列来判断必填项。这个方法可以通用

    errMsg = ""

    g_sheet_APE = Sheets("Config").Cells(5, 1).Value
    Set checkDict = CreateObject("Scripting.Dictionary")

    startIndex = 3
    endindex = Sheets(g_sheet_APE).UsedRange.Rows.Count
    For RowIndex = startIndex To endindex
        ' 第四列为key
        Key = Sheets(g_sheet_APE).Cells(RowIndex, 4).Value
        ' 第一列为中文key
        keyZH = Sheets(g_sheet_APE).Cells(RowIndex, 1).Value
         ' 中文key删去字符  【*是否在线：】 -> 【是否在线】
        keyZH = Replace(Mid(keyZH, 2), "：", "")

        ' 第三列， 是否必填项
        IsRequired = Sheets(g_sheet_APE).Cells(RowIndex, 3).Value
        cellValue = Sheets(g_sheet_APE).Cells(RowIndex, 5).Value

        If IsRequired = 1 And cellValue = "" Then
            checkDict.Add RowIndex, keyZH
        End If
    Next

    If checkDict.Count > 0 Then
        errMsg = "请填写"
        '   请填写第3行（）、第4行（）
        k = checkDict.keys
        v = checkDict.Items
        For i = 0 To checkDict.Count - 1
            errMsg = errMsg & "第" & k(i) & "行（" & v(i) & "） "
        Next
    End If

    'MsgBox errMsg

    CheckRequiredParams = errMsg

End Function

Function CheckValidParams()
    ' 校验参数格式。
    ' 本方法各个对象需要单独写，无法通用

    '  规则只能在这边代码里 写死

    errMsg = ""

    g_sheet_APE = Sheets("Config").Cells(5, 1).Value

    Set configDict = CreateObject("Scripting.Dictionary")
    ' 这个字典只是提示信息。  每个规则要单独定义处理规则，以及添加对应的处理函数

    configDict.Add "ApeID", "设备ID：请输入20位数字"
    configDict.Add "IPAddr", "IP地址：请输入正确的IP地址"
    configDict.Add "Port", "端口号：请输入正确的端口"
    configDict.Add "Longitude", "经度：请输入正确经度"
    configDict.Add "Latitude", "纬度：请输入正确纬度"
    configDict.Add "OrgCode", "管辖单位代码：请输入12位数字"

    apeid = Sheets(g_sheet_APE).Cells(3, 5).Value
    If g_tool_checkNumberAndWidth(apeid, 20) Then
        configDict.Remove ("ApeID")
    End If

    ipaddr = Sheets(g_sheet_APE).Cells(7, 5).Value
    If g_tool_isIpFormat(ipaddr) Then
        configDict.Remove ("IPAddr")
    End If

    port = Sheets(g_sheet_APE).Cells(8, 5).Value
    If g_tool_checkPort(port) Then
        configDict.Remove ("Port")
    End If

    longitude = Sheets(g_sheet_APE).Cells(9, 5).Value
    If g_tool_isLongitudeFormat(longitude) Then
        configDict.Remove ("Longitude")
    End If

    latitude = Sheets(g_sheet_APE).Cells(10, 5).Value
    If g_tool_isLatitudeFormat(latitude) Then
        configDict.Remove ("Latitude")
    End If

    orgcode = Sheets(g_sheet_APE).Cells(19, 5).Value  ' 这个不是必须值，可以为空
    If orgcode = "" Or g_tool_checkNumberAndWidth(orgcode, 12) Then  ' 好像不是短路执行，Or的都要执行
        configDict.Remove ("OrgCode")
    End If

    If configDict.Count > 0 Then
        errMsg = "参数填写错误："
        k = configDict.keys
        v = configDict.Items
        For i = 0 To configDict.Count - 1
            errMsg = errMsg & v(i) & "； "
        Next
    End If

    ' MsgBox errMsg

    CheckValidParams = errMsg

End Function

Public Sub InsertAPEValues()

    g_sheet_APE = Sheets("Config").Cells(5, 1).Value

    ' 创建参数值Dictionary
    Set objectDict = CreateObject("Scripting.Dictionary")

    startIndex = 3
    endindex = Sheets(g_sheet_APE).UsedRange.Rows.Count
    For RowIndex = startIndex To endindex
        ' 第四列为key
        Key = Sheets(g_sheet_APE).Cells(RowIndex, 4).Value
        If Key = "" Then
            Exit For  ' 这里用continue最好，vba不支持
        End If

        ' 第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划）【下拉选从Config那边取值】
        keyType = Sheets(g_sheet_APE).Cells(RowIndex, 2).Value
        ' 第五列为原始值
        cellValue = Sheets(g_sheet_APE).Cells(RowIndex, 5).Value

        If keyType = 0 Then
            objectDict.Add Key, cellValue
        ElseIf keyType = 1 Then
            objectDict.Add Key, g_Fun_GetSelectValue(cellValue, Key)
        ElseIf keyType = 2 Then
            tvalue = g_Fun_GetSelectValues(cellValue, Key)
            If tvalue = 0 Then
                tvalue = ""
            End If
            objectDict.Add Key, tvalue
        Else
            objectDict.Add Key, cellValue
        End If
    Next

    ' 查看对象dict内容
    'MsgBox g_tool_toString(objectDict)

    msg = CheckRequiredParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    msg = CheckValidParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    g_Fun_InsertDict2Sheet objectDict, "Data_APE"
    ' g_Fun_InsertDict2Sheet_1(objectDict, Sheets("Data_APE"))

    Sheets("Data_APE").Visible = True
    Sheets("Data_APE").Activate

End Sub

Public Sub g_Fun_InsertDict2Sheet(dict, sheetName)
    ' 把dict的值填入目标Sheet
    ' 不匹配的字段（跟目标Sheet的首行对比，dict多余的或者缺失的字段） 暂时不处理

    '不用With好像要报错。  之前的代码，先赋值targetSheet = Sheets(sheetName)  然后取值targetSheet.Cells(1, i).Value  赋值语句就报错：对象不支持该属性或方法   【不深究了】

    With Sheets(sheetName)

        startIndex = 1
        endindex = .UsedRange.Columns.Count
        targetline = .UsedRange.Rows.Count
        'MsgBox "列数：" & endindex & " 行数：" & targetline

        For i = startIndex To endindex Step 1
            titleKey = .Cells(1, i).Value
            If dict.Exists(titleKey) Then
                .Cells(targetline + 1, i).Value = dict(titleKey)
            End If
        Next

    End With

End Sub

Public Sub g_Fun_InsertDict2Sheet_1(dict, targetSheet As Worksheet)
    ' 把dict的值填入目标Sheet
    ' 直接传递Sheet作为参数

    startIndex = 1
    endindex = targetSheet.UsedRange.Columns.Count
    targetline = targetSheet.UsedRange.Rows.Count
    'MsgBox "列数：" & endindex & " 行数：" & targetline

    For i = startIndex To endindex Step 1
        titleKey = targetSheet.Cells(1, i).Value
        If dict.Exists(titleKey) Then
            targetSheet.Cells(targetline + 1, i).Value = dict(titleKey)
        End If
    Next

End Sub

Public Function g_tool_toString(dict) As String
    content = "["

    k = dict.keys
    v = dict.Items
    For i = 0 To dict.Count - 1
        content = content & k(i) & "=" & v(i) & ","
    Next
    content = content & "]"

    g_tool_toString = content

End Function

Public Function g_Fun_GetSelectValue(cellValue, typeName)
    ' 从Config里 寻找匹配项的取值

    If cellValue = "请选择" Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    typeMatchRow = 0
    startIndex = 20
    endindex = Sheets("Config").UsedRange.Rows.Count
    For i = startIndex To endindex Step 1
        If typeName = Sheets("Config").Cells(i, 2).Value Then
            typeMatchRow = i
            Exit For
        End If
    Next

    If 0 = typeMatchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    matchRow = 0
    ' 这里用30作为循环结束的数组下标
    For j = typeMatchRow To typeMatchRow + 30 Step 1
        If cellValue = Sheets("Config").Cells(j, 1).Value Then
            matchRow = j
            Exit For
        End If
    Next

    If 0 = matchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    g_Fun_GetSelectValue = Sheets("Config").Cells(matchRow, 2).Value

End Function

Public Function g_Fun_GetSelectValues(cellValue, typeName)
    ' 下拉框多选的取值
    splitArr = Split(Trim(cellValue), "/")

    s = ""
    For Each arrItem In splitArr
        s = s & "/" & g_Fun_GetSelectValue(arrItem, typeName)
    Next

    g_Fun_GetSelectValues = Mid(s, 2)  '去掉最前面的/

End Function

Public Function g_tool_isIpFormat(ipAddress) As Boolean
    '判断ip地址是否合法

    g_tool_isIpFormat = True

    If Trim(ipAddress) = "" Then
        g_tool_isIpFormat = False   '''排空
        Exit Function
    End If

    numArr = Split(Trim(ipAddress), ".")
    arrLen = UBound(numArr) - LBound(numArr) + 1

    If arrLen <> 4 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    Set ipAddrFormat = CreateObject("VBscript.regexp")
    ipAddrFormat.Pattern = "^[0-9.]+$"
    ipAddrFormat.IgnoreCase = True

    Set regRes = ipAddrFormat.Execute(ipAddress)
    If regRes.Count < 1 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    For Each num In numArr
        If Trim(num) = "" Then
            g_tool_isIpFormat = False
            Exit Function
        End If

        If Trim(num) < 0 Or Trim(num) > 255 Then
            g_tool_isIpFormat = False
            Exit Function
        End If
    Next
End Function

Public Function g_tool_checkPort(port) As Boolean
    '判断端口是否合法
    g_tool_checkPort = True

    If Trim(port) = "" Then
        g_tool_checkPort = False   '''排空
        Exit Function
    End If

    If Not IsNumeric(port) Then  '必须为数字
        g_tool_checkPort = False
        Exit Function
    End If

    If InStr(port, ".") Then
        g_tool_checkPort = False
        Exit Function
     End If

    If port < 0 Or port > 65535 Then
        g_tool_checkPort = False
        Exit Function
    End If

End Function

Public Function g_tool_isLongitudeFormat(lxxxtude) As Boolean
    '判断经度是否合法  -180 - +180  纯整数，或者1-6位小数数字
    g_tool_isLongitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLongitudeFormat = False   '''排空
        Exit Function
    End If

    Set lngFormat = CreateObject("VBscript.regexp")
    lngFormat.Pattern = "^[\-\+]?(0?\d{1,2}|1[0-7]\d{1}|180)?(\.\d{1,6})?$"
    lngFormat.IgnoreCase = True

    Set regRes = lngFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLongitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_isLatitudeFormat(lxxxtude) As Boolean
    '判断纬度是否合法  -90 - +90  纯整数，或者1-6位小数数字
    g_tool_isLatitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLatitudeFormat = False   '''排空
        Exit Function
    End If

    Set latFormat = CreateObject("VBscript.regexp")
    latFormat.Pattern = "^[\-\+]?([0-8]?\d{1}|90)(\.\d{1,6})?$"
    latFormat.IgnoreCase = True

    Set regRes = latFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLatitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_checkNumberAndWidth(num, width) As Boolean
    '判断数字以及宽度是否合法
    g_tool_checkNumberAndWidth = True

    If Trim(num) = "" Then
        g_tool_checkNumberAndWidth = False   '''排空
        Exit Function
    End If

    'If Not IsNumeric(num) Then   '必须为数字  20位的数字已经超过限制了，不能用这个来判断了
        'g_tool_checkNumberAndWidth = False
        'Exit Function
    'End If

    If Len(num) <> width Then
        ' w = Len(num)
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

    Set NumberFormat = CreateObject("VBscript.regexp")
    NumberFormat.Pattern = "\d+"
    NumberFormat.IgnoreCase = True

    Set regRes = NumberFormat.Execute(num)
    If regRes.Count < 1 Then
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

End Function

Sheet Data_APE

Private Sub CommandButton1_Click()
    g_Fun_ExportCSV ActiveSheet.Name, "APE"
End Sub

Public Sub g_Fun_ExportCSV(sheetName As String, fileName As String)
    ' 导出内容
    Dim content As String
    content = ""

    With Sheets(sheetName)

        endColumn = .UsedRange.Columns.Count
        endLine = .UsedRange.Rows.Count

        For i = 1 To endColumn
            titleKey = .Cells(1, i).Value
            content = content & titleKey & ","
        Next
        ' 需要删除最后一个, 后面整体对content处理，Replace一下

        content = content & vbCrLf

        For j = 2 To endLine
            For k = 1 To endColumn
                cellValue = .Cells(j, k).Value
                content = content & cellValue & ","
            Next
            ' 需要删除最后一个, 后面整体对content处理，Replace一下
            content = content & vbCrLf
        Next

    End With

    content = Replace(content, "," & vbCrLf, vbCrLf)

    Dim fullPath As String
    fullPath = ThisWorkbook.Path & "\" & fileName & "_" & Format(Now, "yyyymmdd_hhMMss") & ".csv"
     ' 导出文件 编码类型为 utf-8 without bom
    WriteUtf8WithoutBom fullPath, content

    MsgBox "导出到文件'" & fullPath & "'"

End Sub

Function WriteUtf8WithoutBom(fileName As String, content As String)
    ' 导出utf8无BOM编码格式文件

    Dim stream As New ADODB.stream
    stream.Open
    stream.Type = adTypeText
    stream.Charset = "utf-8"
    stream.WriteText content

    '移除前三个字节（0xEF,0xBB,0xBF）
    stream.Position = 3

    Dim newStream As New ADODB.stream
    newStream.Type = adTypeBinary
    newStream.Mode = adModeReadWrite
    newStream.Open

    stream.CopyTo newStream
    stream.Flush
    stream.Close

    newStream.SaveToFile fileName, adSaveCreateOverWrite
    newStream.Flush
    newStream.Close
End Function

[vieyahn2017]

【已解决】如何做excel表的下拉框多选

https://blog.csdn.net/qq_42431881/article/details/83786644

要ActiveX控件的listbox

ListFillRange 定义一个名称管理器（这边引用该名称） ListStyle 选择 1 - fmListStyleOption MultiSelect 选择 1 - fmMultiSelectMulti

控制的代码

Private Sub ListBox1_Change()
    'If ReLoad Then Exit Sub '见下方说明
    s = ""
    For i = 0 To ListBox1.ListCount - 1
       If ListBox1.Selected(i) = True Then s = s & "/" & ListBox1.List(i)
    Next
    ActiveCell = Mid(s, 2)  '去掉最前面的/

    If ActiveCell = "" Then
        ActiveCell = "请选择"
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'listbox显示的目标单元格
    If ActiveCell.Column = 5 And ActiveCell.Row = 15 Then
        t = ActiveCell.Value

        With ListBox1
            For i = 0 To .ListCount - 1 '根据活动单元格内容修改列表框中被选中的内容

                If InStr(t, .List(i)) Then
                    .Selected(i) = True
                Else
                    .Selected(i) = False
                End If
            Next
            'ReLoad = False
            .Top = ActiveCell.Top + ActiveCell.Height '以下语句根据活动单元格位置显示列表框
            .Left = ActiveCell.Left
            .width = ActiveCell.width
            .Visible = True
        End With

        End If

End Sub

该帖子中区别的是： 增加了开关控制，我没测这个功能 模块1中的代码： Public ReLoad As Boolean '开关listbox的change事件

[vieyahn2017]

上面的代码 APE有点写死了。下面的sheet开始用with，要好点

[vieyahn2017]

Sheet Tollgate

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If ActiveCell.Column = 7 And ActiveCell.Row = 1 Then  ' 新增
        InsertObjectValues
        Exit Sub
    End If

    If ActiveCell.Column = 7 And ActiveCell.Row = 2 Then  ' 重填
        result = MsgBox("确定清空已填写内容？", vbOKCancel)
        If result = vbOK Then ResetObjectValues
        Exit Sub
    End If

    If ActiveCell.Column = 8 And ActiveCell.Row = 1 Then  ' 预览
        Sheets("Data_Tollgate").Visible = True
        Sheets("Data_Tollgate").Activate
    End If

    'If ActiveCell.Column = 8 And ActiveCell.Row = 2 Then   ' 导出（在数据页面）
        'CheckValidParams
        'Exit Sub
    'End If

    '点击 是否下拉项  预留的测试功能 - 检查取值有效性
    If ActiveCell.Column = 2 And ActiveCell.Row = 2 Then
        msg = CheckValidParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

    '点击 是否必填项  预留的测试功能
    If ActiveCell.Column = 3 And ActiveCell.Row = 2 Then
        msg = CheckRequiredParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

End Sub

Public Sub ResetObjectValues()

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value

    ' 清空内容 【通用部分】

    With Sheets(g_sheet_Object)

        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            '第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划） 【下拉选从Config那边取值】
            keyType = .Cells(RowIndex, 2).Value

            If keyType = 2 Then
                .Cells(RowIndex, 5).Value = "请选择"
            Else
                .Cells(RowIndex, 5).Value = ""
            End If
        Next

        ' 清空内容 【特殊取值】
        .Cells(8, 5).Value = "停用"
    End With

End Sub

Function CheckRequiredParams()
    ' 检查必填参数。
    ' 通过第三列来判断必填项。这个方法可以通用

    errMsg = ""
    Set checkDict = CreateObject("Scripting.Dictionary")

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)
        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            ' 第四列为key
            Key = .Cells(RowIndex, 4).Value
            ' 第一列为中文key
            keyZH = .Cells(RowIndex, 1).Value
             ' 中文key删去字符  【*是否在线：】 -> 【是否在线】
            keyZH = Replace(Mid(keyZH, 2), "：", "")

            ' 第三列， 是否必填项
            IsRequired = .Cells(RowIndex, 3).Value
            cellValue = .Cells(RowIndex, 5).Value

            If IsRequired = 1 And cellValue = "" Then
                checkDict.Add RowIndex, keyZH
            End If
        Next

    End With

    If checkDict.Count > 0 Then
        errMsg = "请填写"
        '   请填写第3行（）、第4行（）
        k = checkDict.keys
        v = checkDict.Items
        For i = 0 To checkDict.Count - 1
            errMsg = errMsg & "第" & k(i) & "行（" & v(i) & "） "
        Next
    End If

    'MsgBox errMsg

    CheckRequiredParams = errMsg

End Function

Function CheckValidParams()
    ' 校验参数格式。
    ' 本方法各个对象需要单独写，无法通用

    '  规则只能在这边代码里 写死

    errMsg = ""

    Set configDict = CreateObject("Scripting.Dictionary")
    ' 这个字典只是提示信息。  每个规则要单独定义处理规则，以及添加对应的处理函数

    configDict.Add "TollgateID", "卡口ID：请输入20位数字"
    configDict.Add "Longitude", "经度：请输入正确经度"
    configDict.Add "Latitude", "纬度：请输入正确纬度"
    configDict.Add "ActiveTime", "启用时间：请输入正确的时间格式"
    configDict.Add "LaneNum", "卡口车道数：请输入正确的数字"
    configDict.Add "OrgCode", "管辖单位代码：请输入12位数字"

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)

        TollgateID = .Cells(3, 5).Value
        If g_tool_checkNumberAndWidth(TollgateID, 20) Then
            configDict.Remove ("TollgateID")
        End If

        longitude = .Cells(6, 5).Value
        If g_tool_isLongitudeFormat(longitude) Then
            configDict.Remove ("Longitude")
        End If

        latitude = .Cells(7, 5).Value
        If g_tool_isLatitudeFormat(latitude) Then
            configDict.Remove ("Latitude")
        End If

        activeTime = .Cells(11, 5).Value
        If activeTime = "" Or g_tool_checkDateTime(activeTime) Then  ' 时间的校验函数
            configDict.Remove ("ActiveTime")
        End If

        laneNum = .Cells(12, 5).Value
        If laneNum = "" Or g_tool_checkPort(laneNum) Then  ' 车道数目是数字，暂时就用这个端口的校验函数
            configDict.Remove ("LaneNum")
        End If

        orgCode = .Cells(13, 5).Value  ' 这个不是必须值，可以为空
        If orgCode = "" Or g_tool_checkNumberAndWidth(orgCode, 12) Then  ' 好像不是短路执行，Or的都要执行
            configDict.Remove ("OrgCode")
        End If

    End With

    If configDict.Count > 0 Then
        errMsg = "参数填写错误："
        k = configDict.keys
        v = configDict.Items
        For i = 0 To configDict.Count - 1
            errMsg = errMsg & v(i) & "； "
        Next
    End If

    ' MsgBox errMsg

    CheckValidParams = errMsg

End Function

Public Sub InsertObjectValues()

    ' 创建参数值Dictionary
    Set objectDict = CreateObject("Scripting.Dictionary")

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)
        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            ' 第四列为key
            Key = .Cells(RowIndex, 4).Value
            If Key = "" Then
                Exit For  ' 这里用continue最好，vba不支持
            End If

            ' 第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划）【下拉选从Config那边取值】
            keyType = .Cells(RowIndex, 2).Value
            ' 第五列为原始值
            cellValue = .Cells(RowIndex, 5).Value

            If keyType = 0 Then
                objectDict.Add Key, cellValue
            ElseIf keyType = 1 Then
                objectDict.Add Key, g_Fun_GetSelectValue(cellValue, Key)
            ElseIf keyType = 2 Then
                tvalue = g_Fun_GetSelectValues(cellValue, Key)
                If tvalue = 0 Then
                    tvalue = ""
                End If
                objectDict.Add Key, tvalue
            Else
                objectDict.Add Key, cellValue
            End If
        Next

    End With
    ' 查看对象dict内容
    'MsgBox g_tool_toString(objectDict)

    msg = CheckRequiredParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    msg = CheckValidParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    g_Fun_InsertDict2Sheet objectDict, "Data_Tollgate"

    Sheets("Data_Tollgate").Visible = True
    Sheets("Data_Tollgate").Activate

End Sub

Public Sub g_Fun_InsertDict2Sheet(dict, sheetName)
    ' 把dict的值填入目标Sheet
    ' 不匹配的字段（跟目标Sheet的首行对比，dict多余的或者缺失的字段） 暂时不处理

    '不用With好像要报错。  之前的代码，先赋值targetSheet = Sheets(sheetName)  然后取值targetSheet.Cells(1, i).Value  赋值语句就报错：对象不支持该属性或方法   【不深究了】

    With Sheets(sheetName)

        startIndex = 1
        endIndex = .UsedRange.Columns.Count
        targetLine = .UsedRange.Rows.Count
        'MsgBox "列数：" & endindex & " 行数：" & targetline

        For i = startIndex To endIndex Step 1
            titleKey = .Cells(1, i).Value
            If dict.Exists(titleKey) Then
                .Cells(targetLine + 1, i).Value = dict(titleKey)
            End If
        Next

    End With

End Sub

Public Sub g_Fun_InsertDict2Sheet_1(dict, targetSheet As Worksheet)
    ' 把dict的值填入目标Sheet
    ' 直接传递Sheet作为参数

    startIndex = 1
    endIndex = targetSheet.UsedRange.Columns.Count
    targetLine = targetSheet.UsedRange.Rows.Count
    'MsgBox "列数：" & endindex & " 行数：" & targetline

    For i = startIndex To endIndex Step 1
        titleKey = targetSheet.Cells(1, i).Value
        If dict.Exists(titleKey) Then
            targetSheet.Cells(targetLine + 1, i).Value = dict(titleKey)
        End If
    Next

End Sub

Public Function g_tool_toString(dict) As String
    content = "["

    k = dict.keys
    v = dict.Items
    For i = 0 To dict.Count - 1
        content = content & k(i) & "=" & v(i) & ","
    Next
    content = content & "]"

    g_tool_toString = content

End Function

Public Function g_Fun_GetSelectValue(cellValue, typeName)
    ' 从Config里 寻找匹配项的取值

    If cellValue = "请选择" Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    typeMatchRow = 0
    startIndex = 20
    endIndex = Sheets("Config").UsedRange.Rows.Count
    For i = startIndex To endIndex Step 1
        If typeName = Sheets("Config").Cells(i, 2).Value Then
            typeMatchRow = i
            Exit For
        End If
    Next

    If 0 = typeMatchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    matchRow = 0
    ' 这里用30作为循环结束的数组下标
    For j = typeMatchRow To typeMatchRow + 30 Step 1
        If cellValue = Sheets("Config").Cells(j, 1).Value Then
            matchRow = j
            Exit For
        End If
    Next

    If 0 = matchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    g_Fun_GetSelectValue = Sheets("Config").Cells(matchRow, 2).Value

End Function

Public Function g_Fun_GetSelectValues(cellValue, typeName)
    ' 下拉框多选的取值
    splitArr = Split(Trim(cellValue), "/")

    s = ""
    For Each arrItem In splitArr
        s = s & "/" & g_Fun_GetSelectValue(arrItem, typeName)
    Next

    g_Fun_GetSelectValues = Mid(s, 2)  '去掉最前面的/

End Function

Public Function g_tool_isIpFormat(ipAddress) As Boolean
    '判断ip地址是否合法

    g_tool_isIpFormat = True

    If Trim(ipAddress) = "" Then
        g_tool_isIpFormat = False   '''排空
        Exit Function
    End If

    numArr = Split(Trim(ipAddress), ".")
    arrLen = UBound(numArr) - LBound(numArr) + 1

    If arrLen <> 4 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    Set ipAddrFormat = CreateObject("VBscript.regexp")
    ipAddrFormat.Pattern = "^[0-9.]+$"
    ipAddrFormat.IgnoreCase = True

    Set regRes = ipAddrFormat.Execute(ipAddress)
    If regRes.Count < 1 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    For Each num In numArr
        If Trim(num) = "" Then
            g_tool_isIpFormat = False
            Exit Function
        End If

        If Trim(num) < 0 Or Trim(num) > 255 Then
            g_tool_isIpFormat = False
            Exit Function
        End If
    Next
End Function

Public Function g_tool_checkPort(port) As Boolean
    '判断端口是否合法
    g_tool_checkPort = True

    If Trim(port) = "" Then
        g_tool_checkPort = False   '''排空
        Exit Function
    End If

    If Not IsNumeric(port) Then  '必须为数字
        g_tool_checkPort = False
        Exit Function
    End If

    If InStr(port, ".") Then
        g_tool_checkPort = False
        Exit Function
     End If

    If port < 0 Or port > 65535 Then
        g_tool_checkPort = False
        Exit Function
    End If

End Function

Public Function g_tool_isLongitudeFormat(lxxxtude) As Boolean
    '判断经度是否合法  -180 - +180  纯整数，或者1-6位小数数字
    g_tool_isLongitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLongitudeFormat = False   '''排空
        Exit Function
    End If

    Set lngFormat = CreateObject("VBscript.regexp")
    lngFormat.Pattern = "^[\-\+]?(0?\d{1,2}|1[0-7]\d{1}|180)?(\.\d{1,6})?$"
    lngFormat.IgnoreCase = True

    Set regRes = lngFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLongitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_isLatitudeFormat(lxxxtude) As Boolean
    '判断纬度是否合法  -90 - +90  纯整数，或者1-6位小数数字
    g_tool_isLatitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLatitudeFormat = False   '''排空
        Exit Function
    End If

    Set latFormat = CreateObject("VBscript.regexp")
    latFormat.Pattern = "^[\-\+]?([0-8]?\d{1}|90)(\.\d{1,6})?$"
    latFormat.IgnoreCase = True

    Set regRes = latFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLatitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_checkNumberAndWidth(num, width) As Boolean
    '判断数字以及宽度是否合法
    g_tool_checkNumberAndWidth = True

    If Trim(num) = "" Then
        g_tool_checkNumberAndWidth = False   '''排空
        Exit Function
    End If

    'If Not IsNumeric(num) Then   '必须为数字  20位的数字已经超过限制了，不能用这个来判断了
        'g_tool_checkNumberAndWidth = False
        'Exit Function
    'End If

    If Len(num) <> width Then
        ' w = Len(num)
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

    Set NumberFormat = CreateObject("VBscript.regexp")
    NumberFormat.Pattern = "\d+"
    NumberFormat.IgnoreCase = True

    Set regRes = NumberFormat.Execute(num)
    If regRes.Count < 1 Then
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

End Function

Public Function g_tool_checkDateTime(time0) As Boolean
    '判断时间是否合法
    g_tool_checkDateTime = True

    If Trim(time0) = "" Then
        g_tool_checkDateTime = False   '''排空
        Exit Function
    End If

    ' String timeRegex = "^((([0-9]{3}[1-9]|[0-9]{2}[1-9][0-9]{1}|[0-9]{1}[1-9][0-9]{2}|[1-9][0-9]{3})(((0[13578]|1[02])(0[1-9]|[12][0-9]|3[01]))|((0[469]|11)(0[1-9]|[12][0-9]|30))|(02(0[1-9]|[1][0-9]|2[0-8]))))|((([0-9]{2})(0[48]|[2468][048]|[13579][26])|((0[48]|[2468][048]|[3579][26])00))0229))([0-1]?[0-9]|2[0-3])([0-5][0-9])([0-5][0-9])$";
    ' 正则太复杂，这边简单处理吧  套用上面的字符宽度的函数

    If Len(time0) <> 14 Then
        g_tool_checkDateTime = False
        Exit Function
    End If

    Set NumberFormat = CreateObject("VBscript.regexp")
    NumberFormat.Pattern = "\d+"
    NumberFormat.IgnoreCase = True

    Set regRes = NumberFormat.Execute(time0)
    If regRes.Count < 1 Then
        g_tool_checkDateTime = False
        Exit Function
    End If

End Function

[vieyahn2017]

hyperlink的使用

公式：

=HYPERLINK("#'" & Config!A6 & "'!A1", Config!A6)

[vieyahn2017]

最新：增加了行政区三级级联

[vieyahn2017]

vba代码

Public pronvincesDict
Public citiesDict
Public zonesDict

Private Sub UserForm_Initialize()
    InitializeGlobalVariables

    Set pronvincesDict = CreateObject("Scripting.Dictionary")
    Set citiesDict = CreateObject("Scripting.Dictionary")
    Set zonesDict = CreateObject("Scripting.Dictionary")

    With Sheets("PlaceCode")
        g_placeCodeRowLines = .UsedRange.Rows.Count
        For i = 1 To g_placeCodeRowLines
            If Not .Cells(i, 1).Value = "" Then
                pronvincesDict.Add .Cells(i, 1).Value, .Cells(i, 2).Value
            End If
        Next
    End With

    ' ListBox3.List = Array("aa", "bbb", "wewe")
    ListBox3.List = pronvincesDict.keys

End Sub

Private Sub CommandButton1_Click()

    '如果没选择省
    If IsNull(ListBox3.Value) Then
        ListBox3.SetFocus
        Exit Sub
    End If

    If citiesDict.Count = 0 Then  ' 台湾香港澳门，只有一级行政区，直接选择退出
        provinceName = ListBox3.Value
        g_selectedPlaceCodeName = provinceName
        g_selectedPlaceCode = pronvincesDict(provinceName)

    Else ' 大陆三级行政区，必须选择到第三级
        If IsNull(ListBox4.Value) Then
            ListBox4.SetFocus
            Exit Sub
        End If
        If IsNull(ListBox5.Value) Then
            ListBox5.SetFocus
            Exit Sub
        End If

        provinceName = ListBox3.Value
        cityName = ListBox4.Value
        zoneName = ListBox5.Value
        g_selectedPlaceCodeName = provinceName & "/" & cityName & "/" & zoneName
        g_selectedPlaceCode = zonesDict(zoneName)

    End If

    ' MsgBox g_selectedPlaceCode
    UserForm1.Hide
End Sub

Private Sub CommandButton2_Click()
    'If g_selectedPlaceCode = 0 Then
        g_selectedPlaceCodeName = "请选择"
    'End If
    UserForm1.Hide
End Sub

Private Sub ListBox3_Click()

End Sub

Private Sub ListBox3_Change()

    SearchCitiesValues ListBox3.Value

    ListBox4.List = citiesDict.keys
    ListBox5.Clear

End Sub

Private Sub ListBox4_Click()

End Sub

Private Sub ListBox4_Change()
    SearchZonesValues ListBox4.Value
    ListBox5.List = zonesDict.keys
End Sub

Private Sub ListBox5_Change()

End Sub

Private Sub ListBox5_Click()

End Sub

Public Sub SearchCitiesValues(provinceName)
    provinceCode = pronvincesDict(provinceName)
    citiesDict.RemoveAll

    With Sheets("PlaceCode")
        For i = 1 To g_placeCodeRowLines
            If .Cells(i, 3).Value = provinceCode Then
                If Not .Cells(i, 4).Value = "" Then
                    citiesDict.Add .Cells(i, 4).Value, .Cells(i, 5).Value
                End If
            End If
        Next
    End With

End Sub

Public Sub SearchZonesValues(cityName)
    cityCode = citiesDict(cityName)
    zonesDict.RemoveAll

    With Sheets("PlaceCode")
        For i = 1 To g_placeCodeRowLines
            If .Cells(i, 6).Value = cityCode Then
                If Not .Cells(i, 7).Value = "" Then
                    zonesDict.Add .Cells(i, 7).Value, .Cells(i, 8).Value
                End If
            End If
        Next
    End With

End Sub

其中 定义于公共模块的代码

Public g_placeCodeRowLines As Integer

Public g_selectedPlaceCode As String
Public g_selectedPlaceCodeName As String

Public Sub InitializeGlobalVariables()
    g_selectedPlaceCode = 0
    g_placeCodeRowLines = Sheets("PlaceCode").UsedRange.Rows.Count

End Sub

sheet代码

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '行政区划
    If ActiveCell.Column = 5 And ActiveCell.Row = 5 Then
        UserForm1.Show
        ActiveCell.Value = g_selectedPlaceCodeName
        Exit Sub
    End If

End Sub

[vieyahn2017]

Sheet Tollgate 最新

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '行政区划
    If ActiveCell.Column = 5 And ActiveCell.Row = 5 Then
        UserForm1.Show
        ActiveCell.Value = g_selectedPlaceCodeName
        Exit Sub
    End If

    If ActiveCell.Column = 7 And ActiveCell.Row = 1 Then  ' 新增
        InsertObjectValues
        Exit Sub
    End If

    If ActiveCell.Column = 7 And ActiveCell.Row = 2 Then  ' 重填
        result = MsgBox("确定清空已填写内容？", vbOKCancel)
        If result = vbOK Then ResetObjectValues
        Exit Sub
    End If

    If ActiveCell.Column = 8 And ActiveCell.Row = 1 Then  ' 预览
        Sheets("Data_Tollgate").Visible = True
        Sheets("Data_Tollgate").Activate
    End If

    'If ActiveCell.Column = 8 And ActiveCell.Row = 2 Then   ' 导出（在数据页面）
        'CheckValidParams
        'Exit Sub
    'End If

    '点击 是否下拉项  预留的测试功能 - 检查取值有效性
    If ActiveCell.Column = 2 And ActiveCell.Row = 2 Then
        msg = CheckValidParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

    '点击 是否必填项  预留的测试功能
    If ActiveCell.Column = 3 And ActiveCell.Row = 2 Then
        msg = CheckRequiredParams
        If Not msg = "" Then MsgBox msg
        Exit Sub
    End If

End Sub

Public Sub ResetObjectValues()

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value

    ' 清空内容 【通用部分】

    With Sheets(g_sheet_Object)

        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            '第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划） 【下拉选从Config那边取值】
            keyType = .Cells(RowIndex, 2).Value

            If keyType >= 2 Then
                .Cells(RowIndex, 5).Value = "请选择"
            Else
                .Cells(RowIndex, 5).Value = ""
            End If
        Next

        ' 清空内容 【特殊取值】
        .Cells(8, 5).Value = "停用"
    End With

End Sub

Function CheckRequiredParams()
    ' 检查必填参数。
    ' 通过第三列来判断必填项。这个方法可以通用

    errMsg = ""
    Set checkDict = CreateObject("Scripting.Dictionary")

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)
        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            ' 第四列为key
            Key = .Cells(RowIndex, 4).Value
            ' 第一列为中文key
            keyZH = .Cells(RowIndex, 1).Value
             ' 中文key删去字符  【*是否在线：】 -> 【是否在线】
            keyZH = Replace(Mid(keyZH, 2), "：", "")

            ' 第三列， 是否必填项
            IsRequired = .Cells(RowIndex, 3).Value
            cellValue = .Cells(RowIndex, 5).Value

            If IsRequired = 1 And cellValue = "" Then
                checkDict.Add RowIndex, keyZH
            End If
        Next

    End With

    If checkDict.Count > 0 Then
        errMsg = "请填写"
        '   请填写第3行（）、第4行（）
        k = checkDict.keys
        v = checkDict.Items
        For i = 0 To checkDict.Count - 1
            errMsg = errMsg & "第" & k(i) & "行（" & v(i) & "） "
        Next
    End If

    'MsgBox errMsg

    CheckRequiredParams = errMsg

End Function

Function CheckValidParams()
    ' 校验参数格式。
    ' 本方法各个对象需要单独写，无法通用

    '  规则只能在这边代码里 写死

    errMsg = ""

    Set configDict = CreateObject("Scripting.Dictionary")
    ' 这个字典只是提示信息。  每个规则要单独定义处理规则，以及添加对应的处理函数

    configDict.Add "TollgateID", "卡口ID：请输入20位数字"
    configDict.Add "Longitude", "经度：请输入正确经度"
    configDict.Add "Latitude", "纬度：请输入正确纬度"
    configDict.Add "ActiveTime", "启用时间：请输入正确的时间格式"
    configDict.Add "LaneNum", "卡口车道数：请输入正确的数字"
    configDict.Add "OrgCode", "管辖单位代码：请输入12位数字"

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)

        TollgateID = .Cells(3, 5).Value
        If g_tool_checkNumberAndWidth(TollgateID, 20) Then
            configDict.Remove ("TollgateID")
        End If

        longitude = .Cells(6, 5).Value
        If g_tool_isLongitudeFormat(longitude) Then
            configDict.Remove ("Longitude")
        End If

        latitude = .Cells(7, 5).Value
        If g_tool_isLatitudeFormat(latitude) Then
            configDict.Remove ("Latitude")
        End If

        activeTime = .Cells(11, 5).Value
        If activeTime = "" Or g_tool_checkDateTime(activeTime) Then  ' 时间的校验函数
            configDict.Remove ("ActiveTime")
        End If

        laneNum = .Cells(12, 5).Value
        If laneNum = "" Or g_tool_checkPort(laneNum) Then  ' 车道数目是数字，暂时就用这个端口的校验函数
            configDict.Remove ("LaneNum")
        End If

        orgCode = .Cells(13, 5).Value  ' 这个不是必须值，可以为空
        If orgCode = "" Or g_tool_checkNumberAndWidth(orgCode, 12) Then  ' 好像不是短路执行，Or的都要执行
            configDict.Remove ("OrgCode")
        End If

    End With

    If configDict.Count > 0 Then
        errMsg = "参数填写错误："
        k = configDict.keys
        v = configDict.Items
        For i = 0 To configDict.Count - 1
            errMsg = errMsg & v(i) & "； "
        Next
    End If

    ' MsgBox errMsg

    CheckValidParams = errMsg

End Function

Public Sub InsertObjectValues()

    ' 创建参数值Dictionary
    Set objectDict = CreateObject("Scripting.Dictionary")

    g_sheet_Object = Sheets("Config").Cells(7, 1).Value  ' Tollgate

    With Sheets(g_sheet_Object)
        startIndex = 3
        endIndex = .UsedRange.Rows.Count
        For RowIndex = startIndex To endIndex
            ' 第四列为key
            Key = .Cells(RowIndex, 4).Value
            If Key = "" Then
                Exit For  ' 这里用continue最好，vba不支持
            End If

            ' 第二列， 是否下拉项： 0-否  1-下拉单选项 2-下拉多选项  3-特殊（比如三级下拉的行政区划）【下拉选从Config那边取值】
            keyType = .Cells(RowIndex, 2).Value
            ' 第五列为原始值
            cellValue = .Cells(RowIndex, 5).Value

            If keyType = 0 Then
                objectDict.Add Key, cellValue
            ElseIf keyType = 1 Then
                objectDict.Add Key, g_Fun_GetSelectValue(cellValue, Key)
            ElseIf keyType = 2 Then
                tvalue = g_Fun_GetSelectValues(cellValue, Key)
                If tvalue = 0 Then
                    tvalue = ""
                End If
                objectDict.Add Key, tvalue
            Else   '特殊的值，各自单独处理。本excel文件中只有一种：行政区划
                If Key = "PlaceCode" Then
                    objectDict.Add Key, g_selectedPlaceCode
                End If

            End If
        Next

    End With
    ' 查看对象dict内容
    'MsgBox g_tool_toString(objectDict)

    msg = CheckRequiredParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    msg = CheckValidParams
    If Not msg = "" Then
        MsgBox msg
        Exit Sub
    End If

    g_Fun_InsertDict2Sheet objectDict, "Data_Tollgate"

    Sheets("Data_Tollgate").Visible = True
    Sheets("Data_Tollgate").Activate

End Sub

Public Sub g_Fun_InsertDict2Sheet(dict, sheetName)
    ' 把dict的值填入目标Sheet
    ' 不匹配的字段（跟目标Sheet的首行对比，dict多余的或者缺失的字段） 暂时不处理

    '不用With好像要报错。  之前的代码，先赋值targetSheet = Sheets(sheetName)  然后取值targetSheet.Cells(1, i).Value  赋值语句就报错：对象不支持该属性或方法   【不深究了】

    With Sheets(sheetName)

        startIndex = 1
        endIndex = .UsedRange.Columns.Count
        targetLine = .UsedRange.Rows.Count
        'MsgBox "列数：" & endindex & " 行数：" & targetline

        For i = startIndex To endIndex Step 1
            titleKey = .Cells(1, i).Value
            If dict.Exists(titleKey) Then
                .Cells(targetLine + 1, i).Value = dict(titleKey)
            End If
        Next

    End With

End Sub

Public Sub g_Fun_InsertDict2Sheet_1(dict, targetSheet As Worksheet)
    ' 把dict的值填入目标Sheet
    ' 直接传递Sheet作为参数

    startIndex = 1
    endIndex = targetSheet.UsedRange.Columns.Count
    targetLine = targetSheet.UsedRange.Rows.Count
    'MsgBox "列数：" & endindex & " 行数：" & targetline

    For i = startIndex To endIndex Step 1
        titleKey = targetSheet.Cells(1, i).Value
        If dict.Exists(titleKey) Then
            targetSheet.Cells(targetLine + 1, i).Value = dict(titleKey)
        End If
    Next

End Sub

Public Function g_tool_toString(dict) As String
    content = "["

    k = dict.keys
    v = dict.Items
    For i = 0 To dict.Count - 1
        content = content & k(i) & "=" & v(i) & ","
    Next
    content = content & "]"

    g_tool_toString = content

End Function

Public Function g_Fun_GetSelectValue(cellValue, typeName)
    ' 从Config里 寻找匹配项的取值

    If cellValue = "请选择" Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    typeMatchRow = 0
    startIndex = 20
    endIndex = Sheets("Config").UsedRange.Rows.Count
    For i = startIndex To endIndex Step 1
        If typeName = Sheets("Config").Cells(i, 2).Value Then
            typeMatchRow = i
            Exit For
        End If
    Next

    If 0 = typeMatchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    matchRow = 0
    ' 这里用30作为循环结束的数组下标
    For j = typeMatchRow To typeMatchRow + 30 Step 1
        If cellValue = Sheets("Config").Cells(j, 1).Value Then
            matchRow = j
            Exit For
        End If
    Next

    If 0 = matchRow Then
        g_Fun_GetSelectValue = 0
        Exit Function
    End If

    g_Fun_GetSelectValue = Sheets("Config").Cells(matchRow, 2).Value

End Function

Public Function g_Fun_GetSelectValues(cellValue, typeName)
    ' 下拉框多选的取值
    splitArr = Split(Trim(cellValue), "/")

    s = ""
    For Each arrItem In splitArr
        s = s & "/" & g_Fun_GetSelectValue(arrItem, typeName)
    Next

    g_Fun_GetSelectValues = Mid(s, 2)  '去掉最前面的/

End Function

Public Function g_tool_isIpFormat(ipAddress) As Boolean
    '判断ip地址是否合法

    g_tool_isIpFormat = True

    If Trim(ipAddress) = "" Then
        g_tool_isIpFormat = False   '''排空
        Exit Function
    End If

    numArr = Split(Trim(ipAddress), ".")
    arrLen = UBound(numArr) - LBound(numArr) + 1

    If arrLen <> 4 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    Set ipAddrFormat = CreateObject("VBscript.regexp")
    ipAddrFormat.Pattern = "^[0-9.]+$"
    ipAddrFormat.IgnoreCase = True

    Set regRes = ipAddrFormat.Execute(ipAddress)
    If regRes.Count < 1 Then
        g_tool_isIpFormat = False
        Exit Function
    End If

    For Each num In numArr
        If Trim(num) = "" Then
            g_tool_isIpFormat = False
            Exit Function
        End If

        If Trim(num) < 0 Or Trim(num) > 255 Then
            g_tool_isIpFormat = False
            Exit Function
        End If
    Next
End Function

Public Function g_tool_checkPort(port) As Boolean
    '判断端口是否合法
    g_tool_checkPort = True

    If Trim(port) = "" Then
        g_tool_checkPort = False   '''排空
        Exit Function
    End If

    If Not IsNumeric(port) Then  '必须为数字
        g_tool_checkPort = False
        Exit Function
    End If

    If InStr(port, ".") Then
        g_tool_checkPort = False
        Exit Function
     End If

    If port < 0 Or port > 65535 Then
        g_tool_checkPort = False
        Exit Function
    End If

End Function

Public Function g_tool_isLongitudeFormat(lxxxtude) As Boolean
    '判断经度是否合法  -180 - +180  纯整数，或者1-6位小数数字
    g_tool_isLongitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLongitudeFormat = False   '''排空
        Exit Function
    End If

    Set lngFormat = CreateObject("VBscript.regexp")
    lngFormat.Pattern = "^[\-\+]?(0?\d{1,2}|1[0-7]\d{1}|180)?(\.\d{1,6})?$"
    lngFormat.IgnoreCase = True

    Set regRes = lngFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLongitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_isLatitudeFormat(lxxxtude) As Boolean
    '判断纬度是否合法  -90 - +90  纯整数，或者1-6位小数数字
    g_tool_isLatitudeFormat = True

    If Trim(lxxxtude) = "" Then
        g_tool_isLatitudeFormat = False   '''排空
        Exit Function
    End If

    Set latFormat = CreateObject("VBscript.regexp")
    latFormat.Pattern = "^[\-\+]?([0-8]?\d{1}|90)(\.\d{1,6})?$"
    latFormat.IgnoreCase = True

    Set regRes = latFormat.Execute(lxxxtude)
    If regRes.Count < 1 Then
        g_tool_isLatitudeFormat = False
        Exit Function
    End If

End Function

Public Function g_tool_checkNumberAndWidth(num, width) As Boolean
    '判断数字以及宽度是否合法
    g_tool_checkNumberAndWidth = True

    If Trim(num) = "" Then
        g_tool_checkNumberAndWidth = False   '''排空
        Exit Function
    End If

    'If Not IsNumeric(num) Then   '必须为数字  20位的数字已经超过限制了，不能用这个来判断了
        'g_tool_checkNumberAndWidth = False
        'Exit Function
    'End If

    If Len(num) <> width Then
        ' w = Len(num)
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

    Set NumberFormat = CreateObject("VBscript.regexp")
    NumberFormat.Pattern = "\d+"
    NumberFormat.IgnoreCase = True

    Set regRes = NumberFormat.Execute(num)
    If regRes.Count < 1 Then
        g_tool_checkNumberAndWidth = False
        Exit Function
    End If

End Function

Public Function g_tool_checkDateTime(time0) As Boolean
    '判断时间是否合法
    g_tool_checkDateTime = True

    If Trim(time0) = "" Then
        g_tool_checkDateTime = False   '''排空
        Exit Function
    End If

    ' String timeRegex = "^((([0-9]{3}[1-9]|[0-9]{2}[1-9][0-9]{1}|[0-9]{1}[1-9][0-9]{2}|[1-9][0-9]{3})(((0[13578]|1[02])(0[1-9]|[12][0-9]|3[01]))|((0[469]|11)(0[1-9]|[12][0-9]|30))|(02(0[1-9]|[1][0-9]|2[0-8]))))|((([0-9]{2})(0[48]|[2468][048]|[13579][26])|((0[48]|[2468][048]|[3579][26])00))0229))([0-1]?[0-9]|2[0-3])([0-5][0-9])([0-5][0-9])$";
    ' 正则太复杂，这边简单处理吧  套用上面的字符宽度的函数

    If Len(time0) <> 14 Then
        g_tool_checkDateTime = False
        Exit Function
    End If

    Set NumberFormat = CreateObject("VBscript.regexp")
    NumberFormat.Pattern = "\d+"
    NumberFormat.IgnoreCase = True

    Set regRes = NumberFormat.Execute(time0)
    If regRes.Count < 1 Then
        g_tool_checkDateTime = False
        Exit Function
    End If

End Function