从总成绩中提取本班语文成绩

追随乔乔

想用宏实现

autohotey

这不复杂，我感觉公式更好，除非几十个班级。建议增加学号/其他的条件作为唯一值，不然重名时该提取谁？

z865593849

字典提取分数

ykcbf1100

参与一下。。

ykcbf1100

参与一下，字典

1. Sub ykcbf()   '//2024.11.11
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("总成绩")
   
5.     arr = sh.UsedRange
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         d(s) = arr(i, 4)
   
9.     Next
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then
    
12.             With sht
    
13.                 r = .Cells(Rows.Count, 1).End(3).Row
    
14.                 arr = .[a1].Resize(r, 2)
    
15.                 For i = 2 To UBound(arr)
    
16.                     s = arr(i, 1)
    
17.                     If d.exists(s) Then arr(i, 2) = d(s)
    
18.                 Next
    
19.                 .[a1].Resize(r, 2) = arr
    
20.             End With
    
21.         End If
    
22.     Next
    
23.     Set d = Nothing
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Intersect(Sheet3.UsedRange, Sheet3.Rows(1))
    For i = 2 To UBound(Arr, 2)
        StrSQL = StrSQL & " Union All Select 姓名,'" & Arr(1, i) & "' as Type," & Arr(1, i) & " as Score From [总成绩$]"
    Next i
    StrSQL = "Select a.姓名,Score From [" & ActiveSheet.Name & "$]a Left Join (" & Mid(StrSQL, 12) & ")b On a.姓名=b.姓名 Where Type='语文'"
    Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

limonet

关键字：union all+left join

usedrange

。。。。。。。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet3.[a1].CurrentRegion.Value
   
5.     For i = 2 To UBound(arr)
   
6.         dic(arr(i, 1)) = arr(i, 4)
   
7.     Next
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "总成绩" Then
   
10.     brr = sht.Range("a1").CurrentRegion.Value
    
11.         For i = 2 To UBound(brr)
    
12.             If dic.exists(brr(i, 1)) Then
    
13.                 brr(i, 2) = dic(brr(i, 1))
    
14.             End If
    
15.         Next i
    
16.         sht.Range("a1").Resize(UBound(brr), 2) = brr
    
17.     End If
    
18. Next
    
19. Set dic = Nothing
    
20. End Sub
    

复制代码

Qs18

试试.......