有日期的天数及人员天数生成明细数据的难题！

ynzsvt

行数自适应了，结果行数限9999，可改代码拓展。

renkangjizhen

Sub test()
Dim i%, d1, d2, d3
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
For i = 2 To [i65536].End(3).Row
If Not d1.exists(Cells(i, "i").Value) Then
d1(Cells(i, "i").Value) = 1
Else
d1(Cells(i, "i").Value) = d1(Cells(i, "i").Value) + 1
End If
If Not d2.exists(Cells(i, "j").Value) Then
d2(Cells(i, "j").Value) = Cells(i, "k")
Else
d2(Cells(i, "j").Value) = d2(Cells(i, "j").Value) + Cells(i, "k")
End If
If Not d3.exists(Cells(i, "j").Value) Then
d3(Cells(i, "j").Value) = 1
Else
d3(Cells(i, "j").Value) = d3(Cells(i, "j").Value) + 1
End If
Next
Cells(2, 1).Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.keys)
Cells(2, 2).Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.items)
Cells(2, 4).Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.keys)
Cells(2, 5).Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.items)
Cells(2, 6).Resize(d3.Count, 1) = WorksheetFunction.Transpose(d3.items)

Set d1 = Nothing
Set d2 = Nothing
Set d3 = Nothing

End Sub

renkangjizhen

多字典协同，一次性搞定多个项目

lj1226189

ynzsvt 发表于 2025-12-20 21:46
总结果数变化和总人数不是37的要改代码的。

非常牛逼的思路 谢谢 这个确实是没有问题了 但我改了数据 出现了一点偏差 比如 M列张群英 8次 生成明细数据00.zip (204.97 KB, 下载次数: 3)

2025-12-20 22:09 上传

点击文件名下载附件

麻烦你再帮我看一下呢 不胜感激

ynzsvt

题目错了，不会有正确答案的。
一个人干活天数超过了总天数，一天又不能加班。

lj1226189

ynzsvt 发表于 2025-12-20 21:55
行数自适应了，结果行数限9999，可改代码拓展。

换了数据运行后误差8天

ynzsvt

yynrzwh

Sub test()
Sheet1.Activate
ar = Range("a1").CurrentRegion
br = Range("d1").CurrentRegion
n = UBound(br)
ReDim res(1 To 300000, 1 To 3)
VBA.Randomize
For i = 2 To UBound(ar)
    For j = 1 To ar(i, 2)
        x = Int(Rnd * (n - 1) + 2)
        If br(x, 3) = 0 Then Stop
        r = r + 1
        res(r, 1) = ar(i, 1)
        res(r, 2) = br(x, 1)
        res(r, 3) = br(x, 2)
        br(x, 3) = br(x, 3) - 1
        
        If br(x, 3) = 0 Then
            br(x, 1) = br(n, 1)
            br(x, 2) = br(n, 2)
            br(x, 3) = br(n, 3)
            n = n - 1
        End If
    Next
Next

Range("m2").Resize(r, 3) = res
End Sub

lj1226189

懂了 谢谢！这个数有问题