请教数据汇总

mykitami

=LET(s,TRIM(CLEAN(VSTACK(血常规!A2:C9999,生化!A2:C9999))),p,PIVOTBY(SCAN(,INDEX(s,,1),LAMBDA(x,y,IF(y="",x,y))),INDEX(s,,2),INDEX(s,,3),SINGLE,0,0,,0,,INDEX(s,,2)<>""),bt,TAKE(DROP(p,,1),1),numbt,XLOOKUP(bt,{"红细胞数目","血红蛋白浓度","血小板数目","白细胞数目","总胆红素","谷丙转氨酶"},SEQUENCE(,COLUMNS(bt))),ss,SORTBY(DROP(p,,1),numbt,1),dd,REDUCE({"病人信息","学校","班级","姓名","性别"},DROP(TAKE(p,,1),1),LAMBDA(x,y,VSTACK(x,XLOOKUP(y,名单!A2:A11,名单!A2:E11)))),HSTACK(dd,ss))

lshn2015

quqiyuan 发表于 2024-10-27 18:46
不知道是不是这个意思，只要有第一列和第一行，然后把数据筛选出来，仅供参考。。。

谢谢老师，基本就是这个意思。不过筛选出数据后，删除了编号内容再运行的话，会有报错。删除编号中间某个内容再运行的话，最后一个编号也有点问题。老师你看看还能怎么处理一下。不过就现在这个，已经基本可以直接用起来了，非常感谢。

quqiyuan

lshn2015 发表于 2024-10-27 20:46
谢谢老师，基本就是这个意思。不过筛选出数据后，删除了编号内容再运行的话，会有报错。删除编号中间某个 ...

基本按照你的意思修改了下，你测试一下。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set sh1 = wb.Sheets("血常规")
    Set sh2 = wb.Sheets("生化")
    Set sh3 = wb.Sheets("名单")
    Set sh4 = wb.Sheets("汇总")
    arr = sh1.[a1].CurrentRegion
    brr = sh2.[a1].CurrentRegion
    crr = sh3.[a1].CurrentRegion
    r = sh4.Cells(Rows.Count, 1).End(3).Row
    c = sh4.Cells(1, Columns.Count).End(1).Column
    frr = sh4.Range(sh4.[a1], sh4.Cells(r, c))
    grr = Application.Index(frr, 1)
    If r = 1 Then MsgBox "查询数据表格空白！！！": Exit Sub
    ReDim hrr(1 To UBound(frr) - 1, 1 To 2)
    n = UBound(frr) - 1
    Set d = CreateObject("scripting.dictionary")
    ReDim drr(1 To UBound(frr) - 1, 1 To UBound(frr, 2))
    For i = 2 To UBound(frr)
        d(frr(i, 1)) = i - 1: drr(i - 1, 1) = frr(i, 1)
        hrr(i - 1, 1) = i: hrr(i - 1, 2) = sh4.Cells(i, 1).Interior.Color
    Next
    For i = 2 To UBound(crr)
        If d.exists(crr(i, 1)) Then
            For j = 2 To UBound(crr, 2)
                drr(d(crr(i, 1)), j) = crr(i, j)
            Next
        End If
    Next
    For i = 2 To UBound(arr)
        If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
        If d.exists(Trim(arr(i, 1))) And arr(i, 2) <> Empty Then
            x = d(Trim(arr(i, 1))): y = Application.Match(arr(i, 2), grr, 0)
            drr(x, y) = arr(i, 3)
        End If
    Next
    For i = 2 To UBound(brr)
        If brr(i, 1) = Empty Then brr(i, 1) = brr(i - 1, 1)
        If d.exists(Trim(brr(i, 1))) And brr(i, 2) <> Empty Then
            x = d(Trim(brr(i, 1))): y = Application.Match(brr(i, 2), grr, 0)
            drr(x, y) = brr(i, 3)
        End If
    Next
    With sh4
        .UsedRange.Clear
        .[a1].Resize(UBound(frr), UBound(frr, 2)) = frr
        .Cells(2, 1).Resize(UBound(drr), UBound(drr, 2)).NumberFormat = "@"
        .Cells(2, 1).Resize(n, UBound(drr, 2)) = drr
        .Cells(1, 1).Resize(n + 1, UBound(drr, 2)).Borders.LineStyle = 1
        .Cells(1, 1).Resize(n + 1, UBound(drr, 2)).HorizontalAlignment = xlCenter
        .Cells(1, 1).Resize(n + 1, UBound(drr, 2)).Columns.AutoFit
        For i = 1 To UBound(hrr)
            .Cells(i + 1, 1).Resize(, UBound(drr, 2)).Interior.Color = hrr(i, 2)
        Next
    End With
    Beep
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub
   

lshn2015

quqiyuan 发表于 2024-10-27 21:35
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

感谢老师帮助，干活效率大大提高了