请教用字典嵌套，提取BOM不同层级数据

lele400024

BOM层级仅2级

第一级为楼栋
第二级为对应专业

提取数据 源数据表中 C列中
第一级提取至  目标表中 A列，第一级字典
第二级提取至  目标表中 C列，字典嵌套，对应数据为建筑面积，工程造价，建筑指标
（详见目标表格式）

已写代码

1. Sub ExtractDataUsingDictionary()
   
2.     Dim srcSheet As Worksheet
   
3.     Dim tgtSheet As Worksheet
   
4.     Dim srcRange As Range
   
5.     Dim lastRowSrc As Long
   
6.     Dim dict As Object
   
7.     Dim subDict As Object
   
8. 
   
9.     '设置源数据工作表和目标表工作表
   
10.     Set srcSheet = ThisWorkbook.Sheets("源数据")
    
11.     Set tgtSheet = ThisWorkbook.Sheets("目标表")
    
12. 
    
13.     '获取源数据工作表的最后一行
    
14.     lastRowSrc = srcSheet.Cells(srcSheet.Rows.Count, "C").End(xlUp).Row
    
15. 
    
16.     '创建字典
    
17.     Set dict = CreateObject("Scripting.Dictionary")
    
18. 
    
19.     '提取数据到字典
    
20.     For i = 2 To lastRowSrc
    
21.         If InStr(srcSheet.Cells(i, "C"), "栋") > 0 Then
    
22.             '创建新的子字典
    
23.             Set subDict = CreateObject("Scripting.Dictionary")
    
24.             If Not dict.Exists(srcSheet.Cells(i, "C")) Then '检查键是否已存在
    
25.                 dict(srcSheet.Cells(i, "C")) = subDict
    
26.             Else
    
27.                 MsgBox "重复的楼栋键: " & srcSheet.Cells(i, "C")
    
28.                 Exit Sub
    
29.             End If
    
30.         End If
    
31.         If dict.Exists(srcSheet.Cells(i, "C")) Then
    
32.             On Error Resume Next '添加错误处理
    
33.             subDict(srcSheet.Cells(i, "C")) = Array(srcSheet.Cells(i, "L"), srcSheet.Cells(i, "C").Offset(0, 1), srcSheet.Cells(i, "D"), srcSheet.Cells(i, "M"))
    
34.             If Err.Number <> 0 Then '检查是否发生错误
    
35.                 MsgBox "在处理数据时发生错误: " & Err.Description
    
36.                 Err.Clear '清除错误
    
37.             End If
    
38.             On Error GoTo 0 '恢复默认的错误处理
    
39.         End If
    
40.     Next i
    
41. 
    
42.     '将字典数据写入目标表
    
43.     i = 2
    
44.     For Each Key In dict.Keys
    
45.         tgtSheet.Cells(i, 1) = Key
    
46.         For Each subKey In dict(Key).Keys
    
47.             tgtSheet.Cells(i, 2) = dict(Key)(subKey)(0)
    
48.             tgtSheet.Cells(i, 3) = dict(Key)(subKey)(1)
    
49.             tgtSheet.Cells(i, 4) = dict(Key)(subKey)(2)
    
50.             tgtSheet.Cells(i, 5) = dict(Key)(subKey)(3)
    
51.             i = i + 1
    
52.         Next subKey
    
53.     Next Key
    
54. End Sub
    

复制代码

字典嵌套提取.rar (23.92 KB, 下载次数: 5)

2024-7-15 16:59 上传

点击文件名下载附件

目前存在问题，请各位老师帮帮忙修改下代码，谢谢

abc123281

字典嵌套提取123.rar (25.63 KB, 下载次数: 12)

2024-7-16 00:07 上传

点击文件名下载附件

abc123281

其实不需要用字典的
Sub 拆分abc()
Dim arr, brr(1 To 10000, 1 To 5)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Worksheets("源数据")
  r = .[c65536].End(xlUp).Row
  arr = .Range("a1:m" & r)
  Rng = Array("楼栋号", "建筑面积", "专业名称", "工程造价（元）", "建筑指标（元/㎡）")
  For i = 3 To UBound(arr)
    If InStr(arr(i, 3), "栋") <> 0 Then
      mx = arr(i, 3)
    Else
      n = n + 1
      brr(n, 1) = mx
      brr(n, 2) = arr(i, 12)
      brr(n, 3) = arr(i, 3)
      brr(n, 4) = arr(i, 4)
      brr(n, 5) = arr(i, 13)
    End If
  Next
End With
With Worksheets("目标表")
  .Range("a1").Resize(1, 5) = Rng
  .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok！", 64
End Sub

lele400024

abc123281 发表于 2024-7-16 00:07

感谢，完美解决，附上中文解释

1. Sub 拆分abc123释义()
   
2.     '定义数组arr和brr
   
3.     Dim arr, brr
   
4.     '创建一个Scripting.Dictionary对象
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     '关闭显示警告和屏幕更新
   
7.     Application.DisplayAlerts = False
   
8.     Application.ScreenUpdating = False
   
9.     '在"源数据"工作表中进行操作
   
10.     With Worksheets("源数据")
    
11.         '获取C列最后一个有数据的行号
    
12.         r = .[c65536].End(xlUp).Row
    
13.         '将A1:M列的数据赋值给数组arr
    
14.         arr = .Range("a1:m" & r)
    
15.         '定义一个包含特定表头名称的数组
    
16.         Rng = Array("楼栋号", "建筑面积", "专业名称", "工程造价（元）", "建筑指标（元/㎡）")
    
17.         '从第3行开始循环到数组arr的上界
    
18.         For i = 3 To UBound(arr)
    
19.           If arr(i, 2) <> "" Then
    
20.             '如果第3列的单元格值包含"栋"字
    
21.             If InStr(arr(i, 2), ".") = 0 Then
    
22.                 '将当前单元格值赋值给变量mx
    
23.                 mx = arr(i, 3)
    
24.             Else
    
25.                 '如果字典d中不存在mx这个键，新建字典，key为mx
    
26.                 If Not d.exists(mx) Then
    
27.                     '初始化计数器m为1，当key为新key时，并重新定义brr数组
    
28.                     m = 1
    
29.                     ReDim brr(1 To 5, 1 To m)
    
30.                 Else
    
31.                     '获取字典中mx对应的值（即brr数组）
    
32.                     brr = d(mx)
    
33.                     '更新计数器m
    
34.                     m = UBound(brr, 2) + 1
    
35.                     '重新调整brr数组大小
    
36.                     ReDim Preserve brr(1 To 5, 1 To m)
    
37.                 End If
    
38.                 '为brr数组赋值
    
39.                 brr(1, m) = mx
    
40.                 brr(2, m) = arr(i, 12)
    
41.                 brr(3, m) = arr(i, 3)
    
42.                 brr(4, m) = arr(i, 4)
    
43.                 brr(5, m) = arr(i, 13)
    
44.                 '将brr数组存入字典d，键为mx
    
45.                 d(mx) = brr
    
46.             End If
    
47.           End If
    
48.         Next
    
49.     End With
    
50.     '定义新的数组zrr
    
51.     Dim zrr(1 To 10000, 1 To 5)
    
52.     '遍历字典d的键
    
53.     For Each aa In d.keys
    
54.         '获取字典中对应键的值（即数组arr）
    
55.         arr = d(aa)
    
56.         '循环处理数组arr
    
57.         For j = 1 To UBound(arr, 2)
    
58.             '计数器n递增
    
59.             n = n + 1
    
60.             '将arr的值复制到zrr中，转置
    
61.             For i = 1 To UBound(arr)
    
62.                 zrr(n, i) = arr(i, j)
    
63.             Next
    
64.         Next
    
65.     Next
    
66.     '在"目标表"工作表中进行操作
    
67.     With Worksheets("目标表")
    
68.         '在A1单元格写入表头
    
69.       .Range("a1").Resize(1, 5) = Rng
    
70.         '将zrr数组的值写入到指定区域
    
71.       .Range("a2").Resize(UBound(zrr), UBound(zrr, 2)) = zrr
    
72.     End With
    
73.     '恢复显示警告和屏幕更新
    
74.     Application.DisplayAlerts = True
    
75.     Application.ScreenUpdating = True
    
76.     '弹出消息框显示"ok！"
    
77.     MsgBox "ok！", 64
    
78. End Sub
    

复制代码

lele400024

abc123281 发表于 2024-7-16 09:49
其实不需要用字典的
Sub 拆分abc()
Dim arr, brr(1 To 10000, 1 To 5)

代码更简单了，厉害
可能被标题误导了

lele400024

abc123281 发表于 2024-7-16 09:49
其实不需要用字典的
Sub 拆分abc()
Dim arr, brr(1 To 10000, 1 To 5)

想到了一个有意思的，如果有三级呢，这个只有两级，如果有三级分级，怎么提取呢，是不是就要字典了

abc123281

lele400024 发表于 2024-7-16 10:37
想到了一个有意思的，如果有三级呢，这个只有两级，如果有三级分级，怎么提取呢，是不是就要字典了

1 注释写得正确，理解到位。
2 如果有三级，那要看数据表是什么样子的，针对性的来使用字典，有时也不一定需要使用字典。