求大神帮忙把分表中的数据复制到汇总表里

翁知江安

Sub Test1()
Dim i, j, k, m, n, irow, icolumn As Integer
Dim tepar, ar, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ReDim ar(1 To 1000, 1 To 8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To Sheets.Count
  If InStr(Sheets(i).Name, "班") > 0 Then
    irow = Sheets(i).[a65536].End(xlUp).Row
    icolumn = Sheets(i).[iv2].End(xlToLeft).Column
    tepar = Sheets(i).Range("a1:i" & irow)
    For j = 3 To 5
      d(tepar(2, j)) = d(tepar(2, j)) + 1
      m = m + 1
      ar(m, 1) = tepar(2, j): ar(m, 2) = tepar(irow, j): ar(m, 3) = Sheets(i).Name: ar(m, 4) = tepar(irow - 6, j)
      For k = irow - 4 To irow - 1
      ar(m, k - irow + 9) = tepar(k, j)
      Next
    Next
  End If
Next
With Sheets("汇总")
.[a2] = "学科": .[b2] = "教师": .[c2] = "班级": .[d2] = "参考人数": .[e2] = "平均分": .[f2] = "及格率(%)": .[g2] = "优秀率(%)": .[h2] = "三率和(%)"
.[a3].Resize(1000, 8).ClearContents
.[a3].Resize(1000, 8).ClearFormats
.[a3].Resize(m, 8) = ar
.[a2].Resize(m + 1, 8).Sort key1:=Columns("a"), order1:=xlDescending, Header:=xlYes, key1:=Columns("c"), order1:=xlAscending, Header:=xlYes
br = .[a1].Resize(m + 3, 8)
For n = 4 To m + 3
  If br(n - 1, 1) <> br(n, 1) Then
     If d(br(n - 1, 1)) > 1 Then
     .Cells(n - d(br(n - 1, 1)), 1).Resize(d(br(n - 1, 1)), 1).Merge
     End If
  End If
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

翁知江安

供参考，欢迎批评指正。

dtang

翁知江安 发表于 2024-12-23 14:35
供参考，欢迎批评指正。

谢谢大神。

3190496160

Sub 成绩分析()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("原始数据")
    r = .Cells(Rows.count, 1).End(xlUp).Row
    ar = .Range("a2:i" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        s = Left(ar(i, 1), 3)
        If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
        d(s)(i) = ""
    End If
Next i
ReDim br(1 To d.count, 1 To 24)
For Each k In d.keys
    n = n + 1
    br(n, 3) = k
    lh = 4
    For j = 3 To 5
        For Each kk In d(k).keys
            If ar(kk, j) <> "" Then
                If IsNumeric(ar(kk, j)) Then
                    br(n, lh) = br(n, lh) + 1 ''参考人数
                    br(n, lh + 2) = br(n, lh + 2) + ar(kk, j) ''总分
                    If ar(kk, j) >= 60 Then
                        br(n, lh + 3) = br(n, lh + 3) + 1 ''及格人数
                    End If
                    If ar(kk, j) >= 90 Then
                        br(n, lh + 4) = br(n, lh + 4) + 1 ''优秀人数
                    End If
                End If
            Else
                br(n, lh + 1) = br(n, lh + 1) + 1 ''缺考人数
            End If
        Next kk
        lh = lh + 7
    Next j
Next k
For i = 1 To n
    For j = 6 To 20 Step 7
        br(i, j) = Round(br(i, j) / br(i, j - 2), 2) ''平均分
        br(i, j + 1) = Round(br(i, j + 1) / br(i, j - 2), 2) ''及格率
        br(i, j + 2) = Round(br(i, j + 2) / br(i, j - 2), 2) ''优秀率
        br(i, j + 3) = br(i, j) + br(i, j + 1) + br(i, j + 2) ''三率和
    Next j
Next i
        
With Sheets("汇总")
    .UsedRange.Offset(2).Borders.LineStyle = 0
    .UsedRange.Offset(2) = Empty
    .[a3].Resize(n, UBound(br, 2)) = br
    .[a3].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

求助2.rar (77.99 KB, 下载次数: 11)

2024-12-23 15:30 上传

点击文件名下载附件

dtang

3190496160 发表于 2024-12-23 15:30

谢谢大神指导。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.12.23
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set Sh = ThisWorkbook.Sheets("汇总")
   
5.     bt = Application.Transpose(Application.Transpose(Sh.[d1:h1].Value))
   
6.     ReDim brr(1 To 1000, 1 To 8)
   
7.     On Error Resume Next
   
8.     For Each sht In Sheets
   
9.         If InStr(sht.Name, "年级") Then
   
10.             With sht
    
11.                 arr = .UsedRange
    
12.                 For j = 3 To 5
    
13.                     s = arr(2, j) & "|" & .Name
    
14.                     If Not d.exists(s) Then
    
15.                         m = m + 1
    
16.                         d(s) = m
    
17.                         brr(m, 1) = arr(2, j)
    
18.                         brr(m, 3) = .Name
    
19.                         For x = 1 To UBound(bt)
    
20.                             r = .UsedRange.Find(bt(x)).Row
    
21.                             brr(m, x + 3) = arr(r, j)
    
22.                         Next
    
23.                     End If
    
24.                 Next
    
25.             End With
    
26.         End If
    
27.     Next
    
28.     With Sh
    
29.         .[a2:h1000].ClearContents
    
30.         .[a2].Resize(m, 8) = brr
    
31.         .[a2].Resize(m, 8).Borders.LineStyle = 1
    
32.     End With
    
33.     Set d = Nothing
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码

cai2532

留下脚印学习下。