请大佬帮忙根据总表生成分析表

fnjpn

请大佬帮忙根据总表自动生成分析表

fnjpn

恳请各位老师帮忙

scggs

看了下附件，只有几个科目，貌似复制粘贴就可以了

yynrzwh

三率分析.zip (47.2 KB, 下载次数: 21)

2024-5-7 16:12 上传

点击文件名下载附件

fnjpn

yynrzwh 发表于 2024-5-7 16:12

非常感谢帮助，谢谢

fnjpn

yynrzwh 发表于 2024-5-7 16:12

老师你好，当总表中的学校数目、科目数及每科分析的项目变化时，如何自动分析分析表的项目呢

yynrzwh

fnjpn 发表于 2024-5-8 09:03
老师你好，当总表中的学校数目、科目数及每科分析的项目变化时，如何自动分析分析表的项目呢

上附件吧。。

fnjpn

Sub test()
Dim wsS As Worksheet, wsA As Worksheet
    Dim sHr As Long, aHr As Long
    Dim hRg As Range, sC As Range
    Dim cR(), i%, pC%, fF As Boolean
    Set wsS = ThisWorkbook.Worksheets("总表")
    Set wsA = ThisWorkbook.Worksheets("分析表 (2)")
    sHr = 2: aHr = 2
    With wsA
        Set hRg = .Range(.Cells(aHr, 1), .Cells(aHr, .Columns.Count).End(xlToLeft))
       Set Rng = .Range(.Cells(2, 1), .Cells(2, .Columns.Count).End(xlToRight))
        dr = Rng.Value
    End With
    ' 动态创建数组
    ReDim cR(1 To hRg.Cells.Count)
    pC = 0 ' 初始化前一列位置
    For Each cell In hRg
        Set sC = wsS.Rows(sHr).Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not sC Is Nothing Then
            cR(i + 1) = sC.Column
            pC = sC.Column ' 更新前一找到的列位置
            fF = True ' 标记已找到
        ElseIf fF Then ' 使用前一列位置
            cR(i) = pC
        End If
        i = i + 1
        fF = False ' 重置找到标记
    Next cell
Set sht = Sheets("总表")
    ar = sht.Range("a1").CurrentRegion
    m = UBound(ar) - 3
With Sheets("分析表")
    .UsedRange.Clear
    c = 1
    k = 0
    For j = 1 To UBound(ar, 2) ' 遍历第一行的所有列
        If InStr(1, ar(1, j), "总分", vbTextCompare) > 0 Then ' 检查是否包含“总分”
            k = k + 1
        End If
    Next j
    For j = 0 To UBound(ar, 2) - 3 Step k
        .Cells(c, 1) = ar(1, j + 3)
        .Cells(c, 1).Resize(1, UBound(cR)).Merge
        .Cells(c + 1, 1).Resize(1, UBound(cR)) = dr
        sD = c: c = c + 1
        For i = 3 To UBound(ar) - 1
            c = c + 1
             For Z = 1 To UBound(cR)
                 If Z > 2 And Z Mod 2 = 0 Then
                    .Cells(c, Z) = Application.Rank(ar(i, j + cR(Z - 1)), sht.Cells(3, j + cR(Z - 1)).Resize(m))
                    Else
                    .Cells(c, Z) = ar(i, cR(Z))
                End If
            Next
        Next
        c = c + 1
    Next
    With .Range("a1").CurrentRegion
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 14
    End With
    For Each col In .Range("2:2").Columns ' 假设表头在第二行
        ' 获取表头单元格的值
        Set headerCell = col.Cells(1)
        headerText = headerCell.Value
        ' 检查表头是否包含"率"字，并设置百分比格式
        If InStr(1, headerText, "率", vbTextCompare) > 0 Then
            headerCell.EntireColumn.NumberFormat = "0.00%"
        End If
    Next col
End With
End Sub

fnjpn

fnjpn 发表于 2024-5-14 14:52
Sub test()
Dim wsS As Worksheet, wsA As Worksheet
    Dim sHr As Long, aHr As Long

谁能帮我简化一下这段代码，谢谢

hbszls

不好意思，刚回复错了。