请教数据汇总

quqiyuan

VBA参与一下，仅供参考。。。

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
    n = 0
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    ReDim drr(1 To UBound(crr) - 1, 1 To 100)
    For i = 2 To UBound(crr)
        d(crr(i, 1)) = i
    Next
    For i = 2 To UBound(arr)
        If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
        If Not d1.exists(arr(i, 2)) And arr(i, 2) <> Empty Then n = n + 1: d1(arr(i, 2)) = n
        If d.exists(Trim(arr(i, 1))) And arr(i, 2) <> Empty Then
            x = d(Trim(arr(i, 1))): y = d1(arr(i, 2))
            drr(x - 1, 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 Not d1.exists(brr(i, 2)) And brr(i, 2) <> Empty Then n = n + 1: d1(brr(i, 2)) = n
        If d.exists(Trim(brr(i, 1))) And brr(i, 2) <> Empty Then
            x = d(Trim(brr(i, 1))): y = d1(brr(i, 2))
            drr(x - 1, y) = brr(i, 3)
        End If
    Next
    With sh4
        .UsedRange.Clear
        .[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
        .Cells(1, UBound(crr, 2) + 1).Resize(, n) = d1.keys
        .Cells(2, UBound(crr, 2) + 1).Resize(UBound(drr), n) = drr
        .UsedRange.Borders.LineStyle = 1
        .UsedRange.HorizontalAlignment = xlCenter
        .UsedRange.Columns.AutoFit
    End With
    Beep
    Set d = Nothing
    Set d1 = Nothing
    Application.ScreenUpdating = True
End Sub

mykitami

=LET(a,VSTACK(血常规!A2:C5000,生化!A2:C5000),b,FILTER(a,INDEX(a,,2)<>""),c,TRIM(SCAN(,TAKE(b,,1),LAMBDA(x,y,IF(y="",x,y)))),d,DROP(REDUCE("",c,LAMBDA(m,n,VSTACK(m,XLOOKUP(n,名单!A2:A11,名单!A2:E11)))),1),e,PIVOTBY(d,INDEX(b,,2),TAKE(b,,-1),SINGLE,0,0,,0,),HSTACK(VSTACK(A1:E1,DROP(TAKE(e,,5),1)),TAKE(e,,-6)))

lshn2015

1786024734 发表于 2024-10-12 15:54
F2=TRANSPOSE(VSTACK(OFFSET(血常规!$A$1,IFNA(MATCH(A2,TRIM(血常规!A:A),)-1,99),2,4),OFFSET(生化!$A$1, ...

谢谢老师，可以直接用

我要成为专家

1. =LET(s,VSTACK(血常规!$A$2:$C$33,生化!$A$2:$C$17),XLOOKUP($A2&F$1,TRIM(SCAN(,TAKE(s,,1),LAMBDA(x,y,IF(y="",x,y))))&CHOOSECOLS(s,2),TAKE(s,,-1),""))

复制代码

lshn2015

quqiyuan 发表于 2024-10-12 16:17
VBA参与一下，仅供参考。。。

体检数据汇总.rar (17 KB, 下载次数: 3)

2024-10-26 00:07 上传

点击文件名下载附件
有些改动

有些新问题，老师看看能不能帮忙解决，谢谢了

zlzz1971

=LET(s,HSTACK(SCAN("",VSTACK(血常规!A2:A33,生化!A2:A17),LAMBDA(x,y,IF(y="",x,TRIM(y)))),VSTACK(血常规!B2:B33,生化!B2:B17),VSTACK(血常规!C2:C33,生化!C2:C17)),IFNA(XLOOKUP(A2:A11&F1:K1,TAKE(s,,1)&CHOOSECOLS(s,2),TAKE(s,,-1)),""))

ericxzhou

Python+Pandas:
import pandas as pd

f = pd.ExcelFile('pandas exercise/sample529.xlsx')
df = pd.concat([f.parse(xs, index_col=0) for xs in f.sheet_names[:2]])
df.index = df.index.to_series().str.strip().ffill()
df1 = f.parse('名单', index_col=0)
df1.join(df.pivot(columns='项目名称').droplevel(0, axis=1)).fillna('')

quqiyuan

lshn2015 发表于 2024-10-26 00:09
有些新问题，老师看看能不能帮忙解决，谢谢了

不知道是不是这个意思，只要有第一列和第一行，然后把数据筛选出来，仅供参考。。。

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("汇总")
    Set sh5 = wb.Sheets("想要的效果")
    arr = sh1.[a1].CurrentRegion
    brr = sh2.[a1].CurrentRegion
    crr = sh3.[a1].CurrentRegion
    frr = sh5.[a1].CurrentRegion
    grr = Application.Index(frr, 1)
    ReDim hrr(1 To UBound(frr) - 1, 1 To 2)
    n = 0
    Set d = CreateObject("scripting.dictionary")
    ReDim drr(1 To UBound(frr) - 1, 1 To UBound(frr, 2))
    For i = 2 To UBound(frr)
        If frr(i, 1) <> Empty Then n = n + 1: d(frr(i, 1)) = n: drr(n, 1) = frr(i, 1)
        If sh5.Cells(i, 1).Interior.Color <> 0 Then hrr(i - 1, 1) = i: hrr(i - 1, 2) = sh5.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 sh5
        .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)
            If hrr(i, 1) <> Empty Then .Cells(i + 1, 1).Resize(, UBound(drr, 2)).Interior.Color = hrr(i, 2)
        Next
    End With
    Beep
    Set d = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub