求助VBA！！！！

gdhgdh_2004

各位路过大侠，求解，万分感谢！！！

02761752696

帮你顶一下

关于求助贴的答复效率与发帖规范

笨鸟飞不高

年月汇总.zip (35.56 KB, 下载次数: 7)

2022-12-22 15:24 上传

点击文件名下载附件

LIUZHU

JS对日期的处理太不友好了，没办法写了个日期函数

LIUZHU

附件在此，请测试

洋务德雷

先用工具简单做了一个，如果想要这样的，我再修改。

gdhgdh_2004

洋务德雷 发表于 2022-12-22 16:03
先用工具简单做了一个，如果想要这样的，我再修改。

是这个意思

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
tm = Timer
With Sheets("生产数据明细表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a2:j" & r)
End With
ReDim arr(1 To UBound(ar), 1 To 8)
With Sheets("汇总表")
    nf = .[c2]
    yf = .[e2]
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            If IsDate(ar(i, 1)) Then
                ye = Year(ar(i, 1))
                If ye = nf Then
                    t = d(Trim(ar(i, 3)))
                    If t = "" Then
                        k = k + 1
                        d(Trim(ar(i, 3))) = k
                        t = k
                        arr(k, 1) = ar(i, 3)
                    End If
                    arr(t, 2) = arr(t, 2) + ar(i, 4)
                    arr(t, 3) = arr(t, 3) + ar(i, 5)
                    yue = Month(ar(i, 1))
                    If yue = yf Then
                        For j = 6 To 10
                            arr(t, j - 2) = arr(t, j - 2) + ar(i, j)
                        Next j
                    End If
                End If
            End If
        End If
    Next i
    If k = "" Then MsgBox "没有符合条件的数据！": End
    .UsedRange.Offset(5) = Empty
    .[b6].Resize(k, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "运行完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
End Sub

3190496160

示例 - 副本.rar (29.58 KB, 下载次数: 5)

2022-12-23 12:22 上传

点击文件名下载附件

gdhgdh_2004

笨鸟飞不高 发表于 2022-12-22 14:51

感谢帮助