大师们，求汇总宏或命令

caimh

点击汇总按钮将数据表“A1:C13”汇总成汇总表显示的结果（根据天数是不是小于26来汇总），汇总表表头增加的项号是指数据汇总后工号出现的次数。

详见以下附件：
Book1.rar (5.84 KB, 下载次数: 7)

2020-3-7 15:39 上传

点击文件名下载附件

wodewan

Option Explicit

Sub test()
Dim arr, i, j, m
Dim d: Set d = CreateObject("scripting.dictionary")
Dim d1: Set d1 = CreateObject("scripting.dictionary")
arr = Sheets("数据").Range("a1").CurrentRegion.Resize(, 4)
For i = 2 To UBound(arr)
    If arr(i, 3) >= 26 Then
        m = m + 1: d1(arr(i, 1)) = d1(arr(i, 1)) + 1
        For j = 1 To 3
            arr(m, j) = arr(i, j)
        Next
           arr(m, 4) = d1(arr(i, 1))
    Else
        If Not d.exists(arr(i, 1)) And arr(i, 3) < 26 Then
            m = m + 1: d(arr(i, 1)) = m: d1(arr(i, 1)) = d1(arr(i, 1)) + 1
            For j = 1 To 3
                arr(m, j) = arr(i, j)
            Next
                arr(m, 4) = d1(arr(i, 1))
        Else
            arr(d(arr(i, 1)), 2) = arr(d(arr(i, 1)), 2) & "," & arr(i, 2)
            arr(d(arr(i, 1)), 3) = arr(d(arr(i, 1)), 3) + arr(i, 3)
        End If
    End If
Next

With Sheets("汇总")
    .Range("A2").CurrentRegion.Offset(1, 0).ClearContents
    .Range("a2").Resize(m, 4) = arr
End With
End Sub

caimh

wodewan 发表于 2020-3-7 16:42
Option Explicit

Sub test()

谢谢大神的热心帮助。

caimh

wodewan 发表于 2020-3-7 16:42
Option Explicit

Sub test()

请大神再帮我看看，如果数据表变成附件的情况求得到相同的效果，怎么办，谢谢！ Book1.rar (5.89 KB, 下载次数: 2)

2020-3-7 17:45 上传

点击文件名下载附件

wodewan

caimh 发表于 2020-3-7 17:45
请大神再帮我看看，如果数据表变成附件的情况求得到相同的效果，怎么办，谢谢！

前面列号做个变量，把里面的常量替换掉，附件供参考。
Sub test()
Dim arr, ar, i, j, m, n
Dim d: Set d = CreateObject("scripting.dictionary")
Dim d1: Set d1 = CreateObject("scripting.dictionary")

With Sheets("数据")
    ar = Array("工号", "机号", "天数")
    For i = 0 To 2
        ar(i) = .Range("a1:bb1").Find(ar(i)).Column
    Next
    n = .Cells(Rows.Count, ar(0)).End(xlUp).Row
    arr = .Range("a1:bb" & n)
End With

For i = 2 To UBound(arr)
    If arr(i, ar(2)) >= 26 Then
        m = m + 1: d1(arr(i, ar(0))) = d1(arr(i, ar(0))) + 1
        For j = 1 To 3
            arr(m, j) = arr(i, ar(j - 1))
        Next
           arr(m, 4) = d1(arr(i, ar(0)))
    Else
        If Not d.exists(arr(i, ar(0))) And arr(i, ar(2)) < 26 Then
            m = m + 1: d(arr(i, ar(0))) = m: d1(arr(i, ar(0))) = d1(arr(i, ar(0))) + 1
            For j = 1 To 3
                arr(m, j) = arr(i, ar(j - 1))
            Next
                arr(m, 4) = d1(arr(i, ar(0)))
        Else
            arr(d(arr(i, ar(0))), 2) = arr(d(arr(i, ar(0))), 2) & "," & arr(i, ar(1))
            arr(d(arr(i, ar(0))), 3) = arr(d(arr(i, ar(0))), 3) + arr(i, ar(2))
        End If
    End If
Next

With Sheets("汇总")
    .Range("A2").CurrentRegion.Offset(1, 0).ClearContents
    .Range("a2").Resize(m, 4) = arr
End With
End Sub

caimh

wodewan 发表于 2020-3-7 18:13
前面列号做个变量，把里面的常量替换掉，附件供参考。
Sub test()
Dim arr, ar, i, j, m, n

先谢过大师，我慢慢比较研究学习一下，真是感恩。

caimh

wodewan 发表于 2020-3-7 18:13
前面列号做个变量，把里面的常量替换掉，附件供参考。
Sub test()
Dim arr, ar, i, j, m, n

With Sheets("数据")
    ar = Array("工号", "机号", "天数")
    For i = 0 To 2
        ar(i) = .Range("a1:bb1").Find(ar(i)).Column
    Next
    n = .Cells(Rows.Count, ar(0)).End(xlUp).Row
    arr = .Range("a1:bb" & n)
End With

大师，这段代码的a1:bb1和a1:bb不明白（特别是bb，为什么是bb），另外行变化了也运行错误（详见附件），研究学习了半天还是摸不着头脑，麻烦大神再帮帮我，感恩先。

见附件： Book1.rar (12.85 KB, 下载次数: 1)

2020-3-7 19:24 上传

点击文件名下载附件

1055751654

bb不是列标吗

caimh

1055751654 发表于 2020-3-7 19:38
bb不是列标吗

为什么列标是bb而不是别的？

1055751654

caimh 发表于 2020-3-7 19:48
为什么列标是bb而不是别的？

可以别的呀，但要保证可以在要查找的范围里面，AD也可以的，你的行变成第2行了，bb1改成range("a2:bb2")就行了