多个工作表按照特定表头对数据进行汇总

jjmysjg

扇扇扇 发表于 2024-8-15 15:51
持续学习中。

大师你好：“生产日期”的列由时间格式换为文本格式（时间换成人名），怎么修改代码，仍然达到原来的汇总效果？
谢谢！

jjmysjg

扇扇扇 发表于 2024-8-15 15:51
持续学习中。

文本格式的，怎样修改代码

扇扇扇

我属于初学者，离大师还十万八千里。
你这个问题，把数组crr的第一列赋值改一下或许可行。

扇扇扇

jjmysjg 发表于 2024-8-16 00:56
大师你好：“生产日期”的列由时间格式换为文本格式（时间换成人名），怎么修改代码，仍然达到原来的汇总 ...

你试试看，不知道行不行。

Sub test()

Dim arr, brr
Dim i%, j%, ii%,  col%
Dim r As Range, sh As Worksheet, d As Object

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Worksheets("汇总")
sh.[a1].CurrentRegion.Offset(1).ClearContents
[a1:j1] = Array("施工人", "方量", "F类粉煤灰F类Ⅱ级", "废石5~10mm", "聚羧酸系高性能减水剂JY-PS-1", "矿粉S95", _
            "普通硅酸盐水泥P·O 42.5R", "人工砂粗砂", "人工砂细砂", "废石5~25mm")
brr = Array("施工人", "方量", "F类粉煤灰F类Ⅱ级", "10mm", "聚羧酸系高性能减水剂JY-PS-1", "矿粉S95", _
            "普通硅酸盐水泥P·O 42.5R", "人工砂粗砂", "人工砂细砂", "25mm")
For Each sht In Worksheets
    If sht.Name <> "汇总" Then
        sht.Activate
    arr = sht.UsedRange
    ReDim crr(1 To UBound(arr), 1 To 10)
    Set r = sht.Cells.Find(brr(0))
        col = r.Column
        m = 0
        For i = LBound(arr) + 1 To UBound(arr)
            If Trim(arr(i, col)) <> "施工人" And Trim(arr(i, col)) <> "" Then
                m = m + 1
                crr(m, 1) = arr(i, col)
            End If
        Next i
     For ii = 1 To 9
        Set r = sht.Cells.Find(brr(ii))
        col = r.Column
        m = 0
        For i = LBound(arr) + 1 To UBound(arr)
            If VarType(arr(i, col)) <> vbString And Trim(arr(i, col)) <> "" Then
                m = m + 1
                crr(m, ii + 1) = arr(i, col)
            End If
        Next i
     Next ii
    sh.Activate
    [a2].Resize(UBound(crr), UBound(crr, 2)) = crr
    End If
Next sht
   
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
        d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), _
                             arr(i, 6), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    Else
        d(arr(i, 1)) = Array(d(arr(i, 1))(0), d(arr(i, 1))(1) + arr(i, 2), d(arr(i, 1))(2) + arr(i, 3), d(arr(i, 1))(3) + arr(i, 4), _
                             d(arr(i, 1))(4) + arr(i, 5), d(arr(i, 1))(5) + arr(i, 6), d(arr(i, 1))(6) + arr(i, 7), _
                             d(arr(i, 1))(7) + arr(i, 8), d(arr(i, 1))(8) + arr(i, 9), d(arr(i, 1))(9) + arr(i, 10))
    End If
    Next i
    brr = Application.Transpose(Application.Transpose(d.items))
    [a1].CurrentRegion.Offset(1).ClearContents
    [a2].Resize(UBound(brr), UBound(brr, 2)) = brr
Set d = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

jjmysjg

扇扇扇 发表于 2024-8-17 15:36
你试试看，不知道行不行。

Sub test()

试一试，谢谢！

扇扇扇

jjmysjg 发表于 2024-8-17 18:17
试一下，不行。
原来的附件，“生产日期”等9个标题与下面的数字格式不同，代码区分了字符串与数值。
...

改一下，写错了。
[a2].Resize(UBound(crr), UBound(crr, 2)) = crr这里把[a2]改cells(range("a1048576").End(xlUp).Row + 1, 1)

blackttea1

留个记号。