根据多个条件筛选各科目的成绩

river4403

求助各位大神：


求教各位大神，有以下一个成绩表，根据“省份”，“市”,"学校"，“考生名字”来做筛选，用VBA如何做成54列的那种格式呢？



感谢！

sdytsxd991122

limonet

公式=PIVOTBY(A1:A49&B1:B49&C1:C49&D1:D49,E1:E49,F1:F49,MAX,,0,,0)

limonet

关键字：pivot

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Transform Max(成绩) Select 省份&市&学校,考生名字 From [Sheet1$A:F] Group By 省份&市&学校,考生名字 Pivot 科目"
    Range("M2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

kdsea

Sub Button1_Click()
    h = Range("a10000").End(xlUp).Row
    For i = 2 To h
      For t = 55 To 56
        If InStr(Cells(t, 2), Cells(i, 1)) > 0 _
                And InStr(1, Cells(t, 2), Cells(i, 2), vbTextCompare) And InStr(Cells(t, 2), Cells(i, 3)) > 0 Then
            If InStr(Cells(55, 3), Cells(i, 4)) > 0 Then
                If Cells(i, 5) = Cells(54, 4) Then Cells(t, 4) = Cells(i, 6)
                If Cells(i, 5) = Cells(54, 5) Then Cells(t, 5) = Cells(i, 6)
                If Cells(i, 5) = Cells(54, 6) Then Cells(t, 6) = Cells(i, 6)
            End If
        End If
        Next
    Next
End Sub

ykcbf1100

全表自动生成，代码通用性强，科目增减都不用改代码了。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.28
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .UsedRange.Columns.Count
   
7.         arr = .[a1].Resize(r, c)
   
8.         ReDim brr(1 To UBound(arr), 1 To 100)
   
9.         m = 1: n = 3
   
10.         brr(1, 1) = "序号"
    
11.         brr(1, 2) = arr(1, 3)
    
12.         brr(1, 3) = arr(1, 4)
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
16.         If Not d.exists(s) Then
    
17.             m = m + 1
    
18.             d(s) = m
    
19.             brr(m, 1) = m - 1
    
20.             brr(m, 2) = arr(i, 1) & arr(i, 2) & arr(i, 3)
    
21.             brr(m, 3) = arr(i, 4)
    
22.         End If
    
23.         r = d(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4))
    
24.         s = arr(i, 5)
    
25.         If Not d.exists(s) Then
    
26.             n = n + 1
    
27.             d(s) = n
    
28.             brr(1, n) = arr(i, 5)
    
29.         End If
    
30.         c = d(arr(i, 5))
    
31.         brr(r, c) = brr(r, c) + arr(i, 6)
    
32.     Next
    
33.     With Sheets("Sheet2")
    
34.         .UsedRange.Clear
    
35.         .[a1].Resize(1, n).Interior.Color = 49407
    
36.         With .[a1].Resize(m, n)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.         End With
    
42.     End With
    
43.     Set d = Nothing
    
44.     Application.ScreenUpdating = False
    
45.     MsgBox "OK！"
    
46. End Sub
    

复制代码

chxw68

练习。。。

river4403

limonet 发表于 2024-7-28 15:19
公式=PIVOTBY(A1:A49&B1:B49&C1:C49&D1:D49,E1:E49,F1:F49,MAX,,0,,0)

感谢感谢！