如何由明细表内的多个小单元数据转换为汇总表的格式

cqcbc

     明细表中的小板块记录、汇总表如图，明细表中的“第一副”对应在汇总表的牌副得分下面的“1”，即B3单元格，第二副对应C3,类推；我们每次过录时的操作，将明细表中的小板块右边的3列内容，剪切到左边三列的下面，进行排序后，再填写到汇总表的的对应单元格。因为比赛位置不固定，还有轮空，比如队号11因故参加不了，所以明细记录表的位置不固定。
比如：
         明细表中的第二副 队号2 的得分是J5单元格，需要写入汇总表的C5单元格；
         明细表中的第三副 队号2 的得分是T9单元格，需要写入汇总表的D5单元格；
         另外，因为比赛的不同，牌的副数不固定，需要判断为空时就停止，如有其它表述不清，请指出。
         请求老师们，帮忙解决，自动生成汇总表。

wang-way

wang-way

wang-way

   第二种方法

cqcbc

wang-way 发表于 2024-6-19 09:17
第二种方法

水平高，看着应该是正确的，请将代码贴出分享一下，对着抄写还没完成。

魂断蓝桥

Option Explicit
Dim m, D
Sub a()
Sheet1.Range("A1:AA1").UnMerge
    Dim c As Range, firstAddress, r As Range, arr, i&, j&, s$
    Set D = CreateObject("Scripting.Dictionary")
    m = 0
    With Sheet1.UsedRange
        Set c = .Find("副", lookat:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Call b(c.Address)
            Do
                Set c = .FindNext(c)
                Call b(c.Address)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With

    Sheet2.Activate
    [b4:aa17] = ""
    arr = [b4:aa17]
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            s = i & "|" & j
            arr(i, j) = D(s)
        Next
    Next
    [b4].Resize(UBound(arr), UBound(arr, 2)) = arr
    Set D = Nothing

With Sheet1.Range("A1:AA1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With
End Sub
Sub b(r)
    Dim i&, j&, s$, arr
    arr = Sheet1.Range(r).CurrentRegion
    m = m + 1
    For i = IIf(m = 1, 4, 3) To UBound(arr)
        For j = 1 To UBound(arr, 2) Step 3
            s = arr(i, j) & "|" & m
            D(s) = arr(i, j + 2)
        Next
    Next
End Sub

cqcbc

wang-way 发表于 2024-6-19 09:17
第二种方法

高手，请将代码贴一下，我抄写了，出来还是有误。
Sub X2()
    Dim wb As Workbook, sht As Worksheet
    Set wb = Application.ThisWorkbook
    Set sht = wb.Worksheets("B组牌副结分")
    Set dic = CreateObject("Scripting.Dictionary")
    With sht
        erow = .Cells(.Rows.Count, 1).End(xlUp).Row
        ecol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xIPrevious).Column
        p = 0
        For i = 1 To erow
            For j = 1 To ecol
                If .Cells(i, j).Value Like "*第*副*" Then
                    p = p + 1
                    For m = i + 2 To i + 11
                        For Each n In Array(0, 3)
                            Key = .Cells(m, j + n).Value
                            If Key <> "" Then
                                dic(Key & "-" & p) = .Cells(m, j + n + 2).Value
                            End If
                        Next n
                    Next m
                End If
            Next j
        Next i
        Set psht = wb.Worksheets("汇总表B组")
        With psht
            .UsedRange.Offset(3, 1).ClearContents
            i = 3
            j = 1
            For Each k In dic
                r = Split(k, "-")(0)
                .Cells(i + r, 1).Value = r
                c = Split(k, "-")(1)
                .Cells(3, j + c).Value = c
                .Cells(i + r, j + c).Value = dic(k)
            Next k
        End With
    End With
End Sub

cqcbc

魂断蓝桥 发表于 2024-6-19 09:33
Option Explicit
Dim m, D
Sub a()

运行后，数据好象不对。

ykcbf1100

数据转置、合计、得分合计、排名一键完成
附件供参考。。。

ykcbf1100

数据转置、合计、得分合计、排名一键完成

1. Sub ykcbf()   '//2024.6.19
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("B组牌副结分")
   
5.         arr = .UsedRange
   
6.         For i = 1 To UBound(arr)
   
7.             If arr(i, 1) Like "*第*副" Then k = k + 1: d(k) = i
   
8.         Next
   
9.     End With
   
10.     t = d.items
    
11.     ReDim brr(1 To 100, 1 To 28)
    
12.     For k = 1 To d.Count
    
13.         r1 = d(k)
    
14.         If k = d.Count Then r2 = UBound(arr) Else r2 = d(k + 1) - 1
    
15.         For j = 1 To UBound(arr, 2) Step 7
    
16.             If arr(r1, j) <> Empty Then
    
17.                 m = m + 1
    
18.                 For i = r1 + 2 To r2 - 2
    
19.                     If Val(arr(i, j)) Then
    
20.                         For x = 1 To 6 Step 3
    
21.                             For y = 1 To 14
    
22.                                 If Val(arr(i, j + x - 1)) = y Then
    
23.                                     brr(y, m) = arr(i, j + x + 1)
    
24.                                 End If
    
25.                             Next
    
26.                         Next
    
27.                     End If
    
28.                 Next
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     With Sheets("汇总表B组")
    
33.         .UsedRange.Offset(3, 1).Clear
    
34.         .[b4].Resize(14, 26) = brr
    
35.         For i = 4 To 17
    
36.             .Cells(i, 28) = Application.Sum(.Cells(i, 2).Resize(, 26))
    
37.         Next
    
38.         For j = 2 To 28
    
39.             .Cells(18, j) = Application.Sum(.Cells(4, j).Resize(m))
    
40.         Next
    
41.         arr = .[ab4].Resize(14)
    
42.         For i = 1 To UBound(arr)
    
43.             j = Application.Match(Application.Large(arr, i), arr, 0)
    
44.             .Cells(j + 3, 29) = i
    
45.         Next
    
46.         With .[a4].Resize(15, 29)
    
47.             .Borders.LineStyle = 1
    
48.             .HorizontalAlignment = xlCenter
    
49.             .VerticalAlignment = xlCenter
    
50.         End With
    
51.     End With
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "OK！"
    
54. End Sub
    

复制代码