寻求VBA帮助，符合条件复制到新的表页中并求和

金牛座艳子

寻求帮助解决VBA符合条件查找引用整行到新的表格中并求和

3190496160

Sub 查询()
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("基础数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "基础数据为空！": End
    ar = .Range("a1:l" & r)
End With
With ActiveSheet
    mc = .Name
    zd = .[b1]
    If mc = "人员" Then
        lh = 3
    ElseIf mc = "项目" Then
        lh = 5
    ElseIf mc = "地区" Then
        lh = 6
    End If
    .[a1].CurrentRegion.Offset(3) = Empty
    br = .Range("a3:j" & UBound(ar) + 2)
    For j = 1 To UBound(br, 2)
        d(br(1, j)) = j
    Next j
    n = 1
    For i = 2 To UBound(ar)
        If Trim(ar(i, lh)) = Trim(zd) Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                lhh = d(ar(1, j))
                If lhh <> "" Then
                    br(n, lhh) = ar(i, j)
                End If
            Next j
            sr = sr + ar(i, 11)
            zc = zc + ar(i, 12)
        End If
    Next i
    If n = 1 Then MsgBox "没有符合条件的数据！": End
    .[a3].Resize(n, UBound(br, 2)) = br
    .[a3].Resize(n, UBound(br, 2)).Sort .[g3], 1, , , , , , 1
    .[c2] = sr
    .[e2] = zc
    .[g2] = .[c2] - .[e2]
End With
Set d = Nothing
MsgBox "ok!"
End Sub

3190496160

代码是三个表通用的
全年数据汇总.rar (24.04 KB, 下载次数: 7)

2023-8-17 18:29 上传

点击文件名下载附件

金牛座艳子

谢谢 老师的 帮助，非常 感谢&#10048;

金牛座艳子

还请麻烦指教一下    如果两个下拉选项  选择的 话VBA怎么操作