字典学习输出表格

wang-way · 发表于 2024-6-25 13:39

来看看我的好不好理解

Public Sub wang_way_VBA()
Dim dic, d, d2, p, n, key, k, i, j, arr, r, eRow
Set dic = CreateObject("Scripting.Dictionary")
Dim wb As Workbook, sht As Worksheet, psht As Worksheet
Set wb = Application.ThisWorkbook
Set sht = wb.Worksheets("Sheet1")
'三层嵌套关系为船号行日期
With sht
eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:C" & eRow)
arr = Rng.Value
For i = LBound(arr) To UBound(arr)
key = CStr(arr(i, 1))
key2 = Format(arr(i, 3), "m月d日")
If Not dic.exists(key) Then '不存在船号
'创建一个船号
Set d = CreateObject("Scripting.Dictionary")
'创建一行
Set d2 = CreateObject("Scripting.Dictionary")
For n = 1 To 31 '----------------添加所有日期控制输出顺序
d2("7月" & n & "日") = ""
Next n '-------------------------------------------------------
d2(key2) = arr(i, 2) '在行内按日期写数据
Set d(1) = d2
Else '存在船号
Set d = dic(key) '取出船号
'循环每一行
newline = True
For Each r In d
Set d2 = d(r)
If d2(key2) = "" Then '如果一行内不存在某个日期则直接写入
d2(key2) = arr(i, 2) '在行内按日期写数据
newline = False
Set d(r) = d2
Exit For
End If
Next r
If newline Then '如果一行内某个日期已经写过新建一行
Set d2 = CreateObject("Scripting.Dictionary")
For n = 1 To 31 '----------------添加所有日期控制输出顺序
d2("7月" & n & "日") = ""
Next n '-------------------------------------------------------
d2(key2) = arr(i, 2) '在行内按日期写数据
Set d(d.Count + 1) = d2 '把新行写入
End If
End If
Set dic(key) = d
'Stop
Next i
i = 7 '起始行
'循环每一个船号
For Each key In dic
'某个船号
Set d = dic(key)
'循环船号的每一行
For Each r In d
'某一行
Set d2 = d(r)
'输出位置下移1行
i = i + 1
.Cells(i, "h").Value = key '船号
.Cells(7, "i").Resize(1, d2.Count).Value = d2.keys '表头
.Cells(i, "i").Resize(1, d2.Count).Value = d2.items '数据行
Next r
Next key
End With
Set dic = Nothing
Set d = Nothing
Set d2 = Nothing
End Sub

复制代码

wang-way · 发表于 2024-6-25 13:46

cqjinxin 发表于 2024-6-25 12:49
大佬好厉害我得好好扣你的代码一个一个翻译偷学

他用的就是棋盘法

半百 · 发表于 2024-6-25 14:42

半百发表于 2024-6-25 12:32

cqjinxin · 发表于 2024-6-25 16:29

wang-way 发表于 2024-6-25 13:46
他用的就是棋盘法

好羡慕这逻辑思维写的简单明了我要学多久才能到这一步

木子客 · 发表于 2024-6-25 21:58

参与一下，正在学习字典
问题是得到了解决，以后再做提升

Sub 填写船号()
Dim arr()
Dim i%, j%, k%
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("A1:D" & Range("A1").End(xlDown).Row) '源数据装入数组
k = 1

For i = 2 To UBound(arr, 1)
      If Not d.exists(arr(i, 1) & "," & arr(i, 4)) Then '查找日期相同且船号相同
         d(arr(i, 1) & "," & arr(i, 4)) = k '通过字典，去掉船号相同但是日期不同的数据
         k = k + 1
      End If
Next

Dim brr(), crr()
Range("H8:AO2000").ClearContents '清空目标区域
brr = d.keys
crr = Range("G8").Resize(d.Count, 33) '设置写入的目标区域

For j = 1 To UBound(arr, 1) '循环源数据数组，写到目标区域数组
For i = LBound(brr) To UBound(brr)
      crr(i + 1, 1) = i + 1
      crr(i + 1, 2) = Mid(brr(i), 1, InStr(brr(i), ",") - 1)
      If arr(j, 1) & "," & arr(j, 4) = brr(i) Then
         crr(i + 1, Day(arr(j, 3)) + 2) = arr(j, 2)
      End If
Next
Next

Range("G8").Resize(d.Count, 33) = crr '写到目标区域
   Debug.Print d.Count
d.RemoveAll
Set d = Nothing
End Sub

h2016 · 发表于 2024-6-25 22:47

半百发表于 2024-6-25 14:42

字典学习输出表格

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

字典学习 输出表格

字典学习输出表格