|
|
今天看了求助贴http://club.excelhome.net/thread-1506094-1-1.html
针对多个基本资料需要建立字典，使用通用代码建立，以减少编程写码繁复
特此编写一个范例，以供大家参考使用。如有不足之处，敬请指出。
附上附件以供参考
多基本资料建立字典的通用建立范例(by.micro).rar
(75.23 KB, 下载次数: 157)
建立模块，抄写代码
- Public dicBSC As Object, dicZGS As Object
- Private vData As Variant, nRow As Double, nCol As Double
- Sub WorkSheetChange(ByVal Target As Range)
- Dim vFill As Variant, rArea As Range, rIntersect As Range
- Dim vIntersect As Variant, vDataCol As Variant, vFillCol As Variant, nI As Long
-
- If dicBSC Is Nothing Or dicZGS Is Nothing Then 建立基本资料
- vFill = Split(",6,35", ",") '办事处标识、子公司的列数
- ReDim vDataCol(1 To UBound(vFill))
- For nI = 1 To UBound(vDataCol)
- vDataCol(nI) = Val(vFill(nI)) '转化为需要处理的列数
- Next
- vFill = Split(",54,57", ",") '对应填写列数
- ReDim vFillCol(1 To UBound(vFill))
- For nI = 1 To UBound(vFillCol)
- vFillCol(nI) = Val(vFill(nI)) '转化为需要填写的列数
- Next
-
- vData = Target.Parent.UsedRange.Value '获取引起变动的表的已用单元格的数据
- If UBound(vData) < 7 Then Exit Sub '当小于7行，即只有标题行
- Application.EnableEvents = False '屏蔽系统响应
- For Each rArea In Target.Areas '检查引起变化的每个单元格区域（因为可能通过Ctrl选择而导致引起多个单元格区域）
- For nI = 1 To UBound(vDataCol) '检查每个需要处理的列
- Set rIntersect = Intersect(rArea, Cells(7, vDataCol(nI)).Resize(UBound(vData) - 6)) '单元格区域与需要处理的列的交集
- If Not rIntersect Is Nothing Then '单元格区域与需要处理的列发生交集
- With rIntersect
- If .Rows.Count = 1 Then '如果交集只有一行，直接获取对应数值时，得到不是数组
- ReDim vIntersect(1 To 1, 1 To 1) '强制使用数组方式，以便后面代码使用
- vIntersect(1, 1) = .Value
- Else
- vIntersect = .Value '交集的数值转换成数组
- End If
- ReDim vFill(.Row To .Row + .Rows.Count - 1, 1 To 1) '建立需要填写结果的数组
- For nRow = LBound(vFill) To UBound(vFill)
- If vDataCol(nI) = 6 Then '办事处标识
- If dicBSC.Exists("|" & vData(nRow, 5) & "|" & vData(nRow, 6)) Then '办事处字典中存在“|省份|城市”
- vFill(nRow, 1) = dicBSC("|" & vData(nRow, 5) & "|" & vData(nRow, 6))
- End If
- ElseIf vDataCol(nI) = 35 Then '子公司
- If dicZGS.Exists("|" & vData(nRow, 35)) Then '子公司字典中存在“|省份”
- If dicZGS("|" & vData(nRow, 35)).Exists(vData(nRow, 5)) Then '“|省份”子公司字典中存在“|城市”
- vFill(nRow, 1) = dicZGS("|" & vData(nRow, 35))("|" & vData(nRow, 5))
- End If
- End If
- End If
- Next
- Cells(LBound(vFill), vFillCol(nI)).Resize(UBound(vFill) - LBound(vFill) + 1) = vFill '在需要填写的列上填上数组
- End With
- End If
- Next
- Next
- Application.EnableEvents = True
- End Sub
- Private Sub 建立基本资料()
- vData = Sheet3.UsedRange.Value
- Set dicBSC = CreateDic(StartRow:=2, UnitKeyCol:="13,14", UnitItemCol:=15) '所属办事处
- Set dicZGS = CreateDic(StartRow:=2, UnitKeyCol:=24, TitleCol:="25,26") '子公司
- End Sub
- Private Function CreateDic(ByVal StartRow As Long, ByVal UnitKeyCol As String, Optional ByVal UnitItemCol As String, Optional ByVal TitleCol As String) As Object
- '功能：根据（多列）关键字列、指定（多列）Item列、指定（多列）标题列，建立字典
- '注意：关键字将用“|Key1|Key2……"形式建立；如果多列Item，将建立为数组；iTem列与标题列不能同时存在，否则优先选用Item列作为建立字典依据
- 'UnitKeyCol，多列关键字时用逗号区分
- 'UnitItemCol，多列Item时用逗号区分
- 'TitleCol，多列标题时用逗号区分
- 'StartRow，数据源起始读取数据行
- Dim oDic As Object
- Dim vKeyCol As Variant, nKeyCol As Double, vItemCol As Variant, nItemCol As Double, vTitleCol As Variant, nTitleCol As Double
- Dim nI As Integer, sKey As String, vItem As Variant, vTitle As Variant
- Dim vTmp As Variant, bItemFirst As Boolean
-
- If UnitKeyCol = "" Then Exit Function '没有关键字列数据
- vTmp = Split(UnitKeyCol, ",") '将关键字列数据转换成数组
- ReDim vKeyCol(UBound(vTmp)) '定义关键字列数组
- For nI = LBound(vTmp) To UBound(vTmp)
- If Int(Val(vTmp(nI))) < 1 Then Exit Function '如果关键字列数被误填为非整数时退出字典建立
- vKeyCol(nI) = Int(Val(vTmp(nI))) '将关键字列数据数组转换成数字
- Next
-
- If UnitItemCol <> "" Then 'Item列数据非空
- vTmp = Split(UnitItemCol, ",") '将Item列数据转换成数组
- ReDim vItemCol(UBound(vTmp)) '定义Item列数组
- For nI = LBound(vTmp) To UBound(vTmp)
- If Int(Val(vTmp(nI))) < 1 Then Exit Function '如果Item列数被误填为非整数时退出字典建立
- vItemCol(nI) = Int(Val(vTmp(nI))) '将Item列数据数组转换成数字
- Next
- If UBound(vItemCol) > 0 Then '非单个Item
- ReDim vItem(1 To UBound(vItemCol) + 1) '定义Item数组
- Else
- vItemCol = vItemCol(0)
- End If
- bItemFirst = True '优先直接使用Item列数据
- ElseIf TitleCol <> "" Then '标题列数据非空
- vTmp = Split(TitleCol, ",") '将标题列数据转换成数组
- ReDim vTitleCol(UBound(vTmp)) '定义标题列数组
- ReDim vTitle(UBound(vTitleCol)) '定义标题数组
- For nI = LBound(vTmp) To UBound(vTmp)
- If Int(Val(vTmp(nI))) < 1 Then Exit Function '如果标题列数被误填为非整数时退出字典建立
- vTitleCol(nI) = Int(Val(vTmp(nI))) '将标题列数据数组转换成数字
- vTitle(nI) = vData(1, vTitleCol(nI)) '记录标题列的标题
- Next
- End If
-
- Set oDic = CreateObject("Scripting.Dictionary") '建立字典
- For nRow = StartRow To UBound(vData) '从开始行StartRow开始检索数据
- If IsArray(vItemCol) Then '如果Item列为数组形式，获取对应Item数组
- For nI = LBound(vItemCol) To UBound(vItemCol)
- nCol = vItemCol(nI)
- vItem(nI + 1) = vData(nRow, nCol)
- Next
- ElseIf vItemCol > 0 Then '如果Item列非数组形式，而且列数大于0，获取对应Item
- vItem = vData(nRow, vItemCol)
- Else
- vItem = Empty
- End If
- sKey = "" '初始化该行的关键字
- For nI = LBound(vKeyCol) To UBound(vKeyCol) '对多列关键字进行连接
- nCol = vKeyCol(nI)
- If vData(nRow, nCol) = "" Then '假如存在空值，重置关键字为空，不对该行进行字典建立
- '注意：该做法是针对所有关键字都不能为空进行设定，假如有其他需求，请另行修改对应逻辑
- sKey = ""
- Exit For
- End If
- sKey = sKey & "|" & vData(nRow, nCol)
- Next
- If sKey <> "" Then
- If IsArray(vTitleCol) And Not bItemFirst Then '如果存在标题列数组并且不是优先直接使用Item列数据
- For nI = LBound(vTitleCol) To UBound(vTitleCol)
- nCol = vTitleCol(nI)
- If Not oDic.Exists(sKey) Then Set oDic(sKey) = CreateObject("Scripting.Dictionary")
- oDic(sKey)("|" & vTitle(nI)) = vData(nRow, nCol) '对每个标题进行字典建立
- Next
- Else
- oDic(sKey) = vItem
- End If
- End If
- Next
-
- Set CreateDic = oDic '返回建立的字典
- End Function
在需要处理的页面添加动作响应代码
- Private Sub Worksheet_Change(ByVal Target As Range)
- WorkSheetChange Target
- End Sub
|
评分
-
7
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-11-2 10:57
楼主
