如何利用VBA求和？

mymotoe6

如何求特定条件的和，并且放到相应位置处？谢谢！

3190496160

Sub 求和()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
zc = DatePart("ww", Date)
nf = Year(Date)
With Sheets("数据透视")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 5 Then MsgBox "数据透视为空": End
    ar = .Range("a1:d" & r)
    ReDim arr(1 To UBound(ar), 1 To 2)
    For i = 6 To UBound(ar)
        If InStr(ar(i, 2), "L") > 0 Then
           ar(i, 1) = ar(i, 2)
        End If
        If Trim(ar(i, 1)) = "" Then
            ar(i, 1) = ar(i - 1, 1)
        End If
        If Val(Left(Trim(ar(i, 2)), 4)) = Val(nf) And Val(Mid(Trim(ar(i, 2)), 5, 2)) = zc Then
            t = d(Trim(ar(i, 1)))
            If t = "" Then
                k = k + 1
                d(Trim(ar(i, 1))) = k
                t = k
                arr(k, 1) = ar(i, 1)
            End If
            arr(t, 2) = arr(t, 2) + ar(i, 3)
        End If
    Next i
    rs = .Cells(Rows.Count, 7).End(xlUp).Row + 1
    .Range("g6:h" & rs) = Empty
    If k = "" Then MsgBox "没有" & zc & "的数据"
    .[g6].Resize(k, 2) = arr
End With
MsgBox "ok!"
End Sub

3190496160

Sub 求和()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
zc = DatePart("ww", Date)
nf = Year(Date)
With Sheets("数据透视")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 5 Then MsgBox "数据透视为空": End
    ar = .Range("a1:d" & r)
    ReDim arr(1 To UBound(ar), 1 To 2)
    For i = 6 To UBound(ar)
        If InStr(ar(i, 2), "L") > 0 Then
           ar(i, 1) = ar(i, 2)
        End If
        If Trim(ar(i, 1)) = "" Then
            ar(i, 1) = ar(i - 1, 1)
        End If
        If Val(Left(Trim(ar(i, 2)), 4)) = Val(nf) And Val(Mid(Trim(ar(i, 2)), 5, 2)) = zc Then
            t = d(Trim(ar(i, 1)))
            If t = "" Then
                k = k + 1
                d(Trim(ar(i, 1))) = k
                t = k
                arr(k, 1) = ar(i, 1)
            End If
            arr(t, 2) = arr(t, 2) + ar(i, 3)
        End If
    Next i
    rs = .Cells(Rows.Count, 7).End(xlUp).Row + 1
    .Range("g6:h" & rs) = Empty
    If k = "" Then MsgBox "没有" & zc & "的数据"
    .[g6].Resize(k, 2) = arr
End With
MsgBox "ok!"
End Sub

3190496160

自动求和.rar (140.82 KB, 下载次数: 8)

2022-2-5 10:12 上传

点击文件名下载附件

mymotoe6

3190496160 发表于 2022-2-5 10:12

太感谢了，好好学习一下，还有个问题，您再给看一下，感谢！

3190496160

'在左侧还有一列数据，请问下应当如何操作？感谢！
不知所云，一头雾水

mymotoe6

3190496160 发表于 2022-2-6 13:07
'在左侧还有一列数据，请问下应当如何操作？感谢！
不知所云，一头雾水

自动求和.rar (154.83 KB, 下载次数: 2)

2022-2-13 14:15 上传

点击文件名下载附件

文件中有两组数据,请问如何操作?谢谢!

3190496160

实在是不知道你的意思，加qq私聊吧