如何根据原始表关键列日期负责生成目标表姓名明细次数

yzyyyyyyy

原始表：日期，负责人1，负责人2
目标表：负责人姓名次数，日期明细，每行满4人折行显示 如何根据原始表关键列日期负责生成目标表姓名明细次数.rar (2.5 KB, 下载次数: 4)

2024-9-5 17:09 上传

点击文件名下载附件

chxw68

详见附件。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。。
Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1:d" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
    ReDim brr(1 To UBound(arr) * 2, 1 To UBound(arr) * 2)
    For i = 3 To UBound(arr)
        For j = 3 To 4
            If arr(i, j) <> Empty Then
                If Not d.exists(arr(i, j)) Then n = n + 1: d(arr(i, j)) = n: brr(n, UBound(brr, 2)) = 1: brr(n, 1) = arr(i, j)
                m = d(arr(i, j))
                brr(m, UBound(brr, 2)) = brr(m, UBound(brr, 2)) + 1
                brr(m, brr(m, UBound(brr, 2))) = arr(i, 1) & "(周" & arr(i, 2) & ")"
            End If
        Next
    Next
    ReDim crr(1 To UBound(brr), 1 To 6)
    crr(1, 2) = "合计"
    m = 1
    For i = 1 To n
        x = brr(i, UBound(brr, 2)) - 1 + x
        crr(1, 3) = x & "次"
        m = m + 1
        crr(m, 1) = i
        crr(m, 2) = brr(i, 1)
        crr(m, 3) = brr(i, UBound(brr, 2)) - 1 & "次"
        For j = 1 To Application.RoundUp((brr(i, UBound(brr, 2)) - 1) / 4, 0)
            m = m + 1
            For k = 2 To 5
            crr(m, k + 1) = brr(i, k + 4 * (j - 1))
        Next k, j
    Next
    Sheet2.[a15].Resize(m, 6) = crr
    Set d = Nothing
    Beep
End Sub