如何按机构名称将多行明细数据统计到汇总表中？？

超越2018

工作中遇到需要将工作表中的明细数据进行汇总统计，每个机构又有很多行数据（各机构的行数据不统一），如何用VBA实现每天数据量的累计汇总，如附件所示，感谢帮助！

shiruiqiang

应该这个意思，希望兄弟医院别来骂

shiruiqiang

Sub text() 'by zhangqi hospital
Dim arr, brr
Dim x, y, m, n
Dim dic, key
Set dic = CreateObject("scripting.dictionary")
Sheets(2).Range("b3:aa100000").ClearContents
arr = Sheets("明细表).[a1].CurrentRegion
For x = 3 To UBound(arr)
If arr(x, 2) <> "" And arr(x, 1) = "" Then
arr(x, 1) = arr(x - 1, 1)
End If

For y = 3 To UBound(arr, 2) - 1
key = arr(x, 1) & "|" & arr(1, y)
dic(key) = dic(key) + Val(arr(x, y))
Next
Next

brr = Sheets(2).[a1].CurrentRegion
For m = 3 To UBound(brr)
For n = 2 To UBound(brr, 2)
key = brr(m, 1) & "|" & brr(1, n)
brr(m, n) = dic(key)
Next
Next
Sheets(2).[a1].CurrentRegion = brr
End Sub

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("明细表")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < 3 Then MsgBox "明细表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
k = 2
arr(1, 1) = ar(1, 1)
arr(2, 1) = ar(2, 1)
For j = 3 To UBound(ar, 2)
    arr(1, j - 1) = ar(1, j)
    arr(2, j - 1) = ar(2, j)
Next j
For i = 3 To UBound(ar)
    If ar(i, 1) = "" Then ar(i, 1) = ar(i - 1, 1)
        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
        For j = 3 To UBound(ar, 2)
            arr(t, j - 1) = arr(t, j - 1) + ar(i, j)
        Next j
Next i
With Sheets("汇总表")
    .[a1].CurrentRegion = Empty
    .[a1].Resize(k, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

各机构数据上传数量统计.rar (25 KB, 下载次数: 17)

2022-12-24 09:24 上传

点击文件名下载附件

gwjkkkkk

Sub TEST7()
    Dim arr, vData, i&, j&, R&, dic As Object, t#, iPosRow&, vItem
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    arr = Sheets(1).[A1].CurrentRegion
    For i = 3 To UBound(arr)
        If arr(i, 1) <> "" Then
            iPosRow = i
           Else
            For j = 3 To UBound(arr, 2)
                arr(iPosRow, j) = arr(iPosRow, j) + arr(i, j)
            Next j
        End If
    Next i
   
    [A1].CurrentRegion.Offset(2) = Empty: R = 2
    vData = [A1].CurrentRegion.Resize(UBound(arr))
    For i = 1 To UBound(vData, 2): dic(Format(vData(1, i), "yyyy-mm-dd")) = i: Next
    For i = 3 To UBound(arr)
        If arr(i, 1) <> "" Then
           R = R + 1
           For j = 1 To UBound(arr, 2)
               vItem = dic(arr(1, j))
                If vItem <> "" Then
                   vData(R, vItem) = arr(i, j)
                End If
           Next j
        End If
    Next i
   
    [A1].Resize(R, UBound(vData, 2)) = vData
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请楼主参考附件。。。

准提部林

Sub TEST_A1()
Dim Arr, i&, j%, k%, N&
Sheet2.UsedRange.ClearContents
Arr = Range(Sheet1.[j1], Sheet1.Cells(Rows.Count, 2).End(xlUp)(1, 0))
For j = 3 To UBound(Arr, 2)
    Arr(1, j - 1) = Arr(1, j): Arr(2, j - 1) = Arr(2, j)
Next j
N = 2
For i = 3 To UBound(Arr)
    If Arr(i, 1) <> "" Then N = N + 1:  Arr(N, 1) = Arr(i, 1): k = 0 Else k = 1
    For j = 3 To UBound(Arr, 2)
        Arr(N, j - 1) = Val(Arr(N, j - 1)) * k + Val(Arr(i, j))
    Next j
Next i
Sheet2.[a1].Resize(N, UBound(Arr, 2) - 1) = Arr
End Sub