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

lele400024 · 发表于 2024-7-15 16:59

BOM层级仅2级

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

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

已写代码

Sub ExtractDataUsingDictionary()
Dim srcSheet As Worksheet
Dim tgtSheet As Worksheet
Dim srcRange As Range
Dim lastRowSrc As Long
Dim dict As Object
Dim subDict As Object
'设置源数据工作表和目标表工作表
Set srcSheet = ThisWorkbook.Sheets("源数据")
Set tgtSheet = ThisWorkbook.Sheets("目标表")
'获取源数据工作表的最后一行
lastRowSrc = srcSheet.Cells(srcSheet.Rows.Count, "C").End(xlUp).Row
'创建字典
Set dict = CreateObject("Scripting.Dictionary")
'提取数据到字典
For i = 2 To lastRowSrc
If InStr(srcSheet.Cells(i, "C"), "栋") > 0 Then
'创建新的子字典
Set subDict = CreateObject("Scripting.Dictionary")
If Not dict.Exists(srcSheet.Cells(i, "C")) Then '检查键是否已存在
dict(srcSheet.Cells(i, "C")) = subDict
Else
MsgBox "重复的楼栋键: " & srcSheet.Cells(i, "C")
Exit Sub
End If
End If
If dict.Exists(srcSheet.Cells(i, "C")) Then
On Error Resume Next '添加错误处理
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"))
If Err.Number <> 0 Then '检查是否发生错误
MsgBox "在处理数据时发生错误: " & Err.Description
Err.Clear '清除错误
End If
On Error GoTo 0 '恢复默认的错误处理
End If
Next i
'将字典数据写入目标表
i = 2
For Each Key In dict.Keys
tgtSheet.Cells(i, 1) = Key
For Each subKey In dict(Key).Keys
tgtSheet.Cells(i, 2) = dict(Key)(subKey)(0)
tgtSheet.Cells(i, 3) = dict(Key)(subKey)(1)
tgtSheet.Cells(i, 4) = dict(Key)(subKey)(2)
tgtSheet.Cells(i, 5) = dict(Key)(subKey)(3)
i = i + 1
Next subKey
Next Key
End Sub

复制代码

字典嵌套提取.rar (23.92 KB, 下载次数: 5)
目前存在问题，请各位老师帮帮忙修改下代码，谢谢

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

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

abc123281 · 发表于 2024-7-16 09:49

其实不需要用字典的
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 · 发表于 2024-7-16 10:27

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

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

Sub 拆分abc123释义()
'定义数组arr和brr
Dim arr, brr
'创建一个Scripting.Dictionary对象
Set d = CreateObject("scripting.dictionary")
'关闭显示警告和屏幕更新
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'在"源数据"工作表中进行操作
With Worksheets("源数据")
'获取C列最后一个有数据的行号
r = .[c65536].End(xlUp).Row
'将A1:M列的数据赋值给数组arr
arr = .Range("a1:m" & r)
'定义一个包含特定表头名称的数组
Rng = Array("楼栋号", "建筑面积", "专业名称", "工程造价（元）", "建筑指标（元/㎡）")
'从第3行开始循环到数组arr的上界
For i = 3 To UBound(arr)
If arr(i, 2) <> "" Then
'如果第3列的单元格值包含"栋"字
If InStr(arr(i, 2), ".") = 0 Then
'将当前单元格值赋值给变量mx
mx = arr(i, 3)
Else
'如果字典d中不存在mx这个键，新建字典，key为mx
If Not d.exists(mx) Then
'初始化计数器m为1，当key为新key时，并重新定义brr数组
m = 1
ReDim brr(1 To 5, 1 To m)
Else
'获取字典中mx对应的值（即brr数组）
brr = d(mx)
'更新计数器m
m = UBound(brr, 2) + 1
'重新调整brr数组大小
ReDim Preserve brr(1 To 5, 1 To m)
End If
'为brr数组赋值
brr(1, m) = mx
brr(2, m) = arr(i, 12)
brr(3, m) = arr(i, 3)
brr(4, m) = arr(i, 4)
brr(5, m) = arr(i, 13)
'将brr数组存入字典d，键为mx
d(mx) = brr
End If
End If
Next
End With
'定义新的数组zrr
Dim zrr(1 To 10000, 1 To 5)
'遍历字典d的键
For Each aa In d.keys
'获取字典中对应键的值（即数组arr）
arr = d(aa)
'循环处理数组arr
For j = 1 To UBound(arr, 2)
'计数器n递增
n = n + 1
'将arr的值复制到zrr中，转置
For i = 1 To UBound(arr)
zrr(n, i) = arr(i, j)
Next
Next
Next
'在"目标表"工作表中进行操作
With Worksheets("目标表")
'在A1单元格写入表头
.Range("a1").Resize(1, 5) = Rng
'将zrr数组的值写入到指定区域
.Range("a2").Resize(UBound(zrr), UBound(zrr, 2)) = zrr
End With
'恢复显示警告和屏幕更新
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'弹出消息框显示"ok！"
MsgBox "ok！", 64
End Sub

复制代码

lele400024 · 发表于 2024-7-16 10:29

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

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

lele400024 · 发表于 2024-7-16 10:37

本帖最后由 lele400024 于 2024-7-16 10:39 编辑

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

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

abc123281 · 发表于 2024-7-16 13:36

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

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

		自动登录	找回密码
密码			免费注册

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

评分