求助：按列提取汇总（格式不变）

hyhsql

求助：按列提取.zip (25.97 KB, 下载次数: 18)

2024-12-20 17:30 上传

点击文件名下载附件

chxw68

参与一下。

cjc209

是不是要把多表数据合并在一起并且字段名不能错位？

hyhsql

列名是自己在第二行任何位置自有写的，放在那一列都可以

hyhsql

感谢chxw68老师的出手，已经能满足要求。就是要注意一个班不能有重名的，有重名就不能统计了。假如能把工作表名在右侧的某单独列显示出来就更好了。总之万分感谢

chxw68

hyhsql 发表于 2024-12-20 18:49
感谢chxw68老师的出手，已经能满足要求。就是要注意一个班不能有重名的，有重名就不能统计了。假如能把工作 ...

同班学生不能有同名的，不同班的学生可以有同名的。

chxw68

修改好了。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.20
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     m = 1: n = 2
   
7.     brr(1, 1) = "班级": brr(1, 2) = "姓名"
   
8.     On Error Resume Next
   
9.     For Each sht In Sheets
   
10.         If sht.Name Like "[A-Z]*" Then
    
11.             arr = sht.UsedRange
    
12.             For i = 2 To UBound(arr)
    
13.                 If arr(i, 1) Like "[A-Z]*" Then
    
14.                     m = m + 1
    
15.                     brr(m, 1) = arr(i, 1)
    
16.                     brr(m, 2) = arr(i, 2)
    
17.                     For j = 3 To UBound(arr, 2)
    
18.                         s = arr(2, j)
    
19.                         If Not d.exists(s) Then
    
20.                             n = n + 1
    
21.                             d(s) = n
    
22.                             brr(1, n) = s
    
23.                         End If
    
24.                         c = d(arr(2, j))
    
25.                         brr(m, c) = brr(m, c) + arr(i, j)
    
26.                     Next
    
27.                 End If
    
28.             Next
    
29.         End If
    
30.     Next
    
31.     With Sheets("按要求多表提取")
    
32.         .UsedRange.Offset(1).Clear
    
33.         .[a2].Resize(1, n).Interior.Color = 49407
    
34.         With .[a2].Resize(m, n)
    
35.             .Value = brr
    
36.             .Borders.LineStyle = 1
    
37.             .HorizontalAlignment = xlCenter
    
38.             .VerticalAlignment = xlCenter
    
39.             With .Font
    
40.                 .Name = "微软雅黑"
    
41.                 .Size = 11
    
42.             End With
    
43.         End With
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    
48. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, k&, r&, dic As Object, iPosCol&, iPosRow&, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Worksheets(1)
        With [A1].CurrentRegion
            .Offset(3).Clear
            ar = .Resize(10 ^ 3).Value
            r = 2
        End With
        For j = 2 To UBound(ar, 2)
            If Len(ar(2, j)) Then dic(ar(2, j)) = j
        Next j
        For k = 2 To Worksheets.Count
            With Worksheets(k)
                With Range(.[A1], .UsedRange)
                    br = Intersect(.Offset(), .Offset(1))
                    For j = 3 To UBound(br, 2)
                        If dic.exists(br(1, j)) Then
                            iPosCol = dic(br(1, j))
                            For i = 2 To UBound(br)
                                If br(i, 1) Like "C*" Then
                                    strKey = br(i, 1) & "," & br(i, 2)
                                    If Not dic.exists(strKey) Then
                                         r = r + 1
                                         dic(strKey) = r
                                    End If
                                    iPosRow = dic(strKey)
                                    ar(iPosRow, 1) = br(i, 1): ar(iPosRow, 2) = br(i, 2)
                                    ar(iPosRow, iPosCol) = br(i, j)
                                End If
                            Next i
                        End If
                    Next j
                End With
            End With
        Next k
        With .[A1].Resize(r, UBound(ar, 2))
            .Value = ar
           .Borders.LineStyle = xlContinuous
        End With
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub