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

cqcbc · 发表于 2024-6-19 11:00

ykcbf1100 发表于 2024-6-19 10:19
数据转置、合计、得分合计、排名一键完成

厉害，排名也搞定了，如果牌的副数变化，只是调整几处，就应该可以使用。谢谢老师。

wang-way · 发表于 2024-6-19 12:51

cqcbc · 发表于 2024-6-19 12:54

wang-way 发表于 2024-6-19 12:51

谢谢帮助，下午去调试。

wang-way · 发表于 2024-6-19 12:55

cqcbc 发表于 2024-6-19 12:54
谢谢帮助，下午去调试。

奇怪的是为什么你写错了它居然不报错

cqcbc · 发表于 2024-6-19 14:56

wang-way 发表于 2024-6-19 09:07

请老师核对一下，到底哪里抄错了，能运行，但结果都是0
Sub X1()
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, xlPrevious).Column
      For t = 1 To 14
         Set D = CreateObject("Scripting.Dictionary")
         Set dic(t) = D
      Next t
      p = 0
      For i = 1 To erow
         For j = 1 To ecol
            If .Cells(i, j).Value Like "*第*副*" Then
                  p = p + 1
                  For t = 1 To 14
                     Set D = dic(t)
                     D(0) = t
                     D(p) = ""
                     Set dic(t) = D
                  Next t
                  For m = i + 2 To i + 11
                     For Each n In Array(0, 3)
                        Key = .Cells(m, j + n).Value
                        If Key <> "" Then
                              Set D = dic(Key)
                              ar = D.items
                              D(p) = .Cells(m, j + n + 2).Value
                              br = D.items
                              Set dic(Key) = D
                        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
         For Each k In dic
            i = i + 1
            Set D = dic(k)
            ar = D.items
            If D.Count > 0 Then .Cells(i, 1).Resize(1, D.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ditems))
         Next k
      End With
End With
End Sub

cqcbc · 发表于 2024-6-19 14:57

本帖最后由 cqcbc 于 2024-6-19 15:01 编辑

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

已测试，正确的，谢谢。评分时点错了，我的权限上限是2分，下次补上。

cqcbc · 发表于 2024-6-19 15:00

wang-way 发表于 2024-6-19 12:51

已修改了，完全正确。谢谢

cqcbc · 发表于 2024-6-19 16:44

ykcbf1100 发表于 2024-6-19 10:19
数据转置、合计、得分合计、排名一键完成

老师，排名的时候，遇上合计得分相同的，会出现空白，请修改一下。

ykcbf1100 · 发表于 2024-6-19 18:34

本帖最后由 ykcbf1100 于 2024-6-19 18:54 编辑

cqcbc 发表于 2024-6-19 16:44
老师，排名的时候，遇上合计得分相同的，会出现空白，请修改一下。

改好了，中国式排名，修正同分排名错乱问题。
代码更新了一下。

ykcbf1100 · 发表于 2024-6-19 18:35

本帖最后由 ykcbf1100 于 2024-6-19 18:53 编辑

中国式排名

Sub ykcbf() '//2024.6.19 中国式排名
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set List = CreateObject("System.Collections.ArrayList")
With Sheets("B组牌副结分")
arr = .UsedRange
For i = 1 To UBound(arr)
If arr(i, 1) Like "*第*副" Then k = k + 1: d(k) = i
Next
End With
t = d.items
ReDim brr(1 To 100, 1 To 28)
For k = 1 To d.Count
r1 = d(k)
If k = d.Count Then r2 = UBound(arr) Else r2 = d(k + 1) - 1
For j = 1 To UBound(arr, 2) Step 7
If arr(r1, j) <> Empty Then
m = m + 1
For i = r1 + 2 To r2 - 2
If Val(arr(i, j)) Then
For x = 1 To 6 Step 3
For y = 1 To 14
If Val(arr(i, j + x - 1)) = y Then
brr(y, m) = arr(i, j + x + 1)
End If
Next
Next
End If
Next
End If
Next
Next
With Sheets("汇总表B组")
.UsedRange.Offset(3, 1).Clear
.[b4].Resize(14, 26) = brr
For i = 4 To 17
.Cells(i, 28) = Application.Sum(.Cells(i, 2).Resize(, 26))
Next
For j = 2 To 28
.Cells(18, j) = Application.Sum(.Cells(4, j).Resize(m))
Next
arr = .[ab4].Resize(14)
For i = 1 To UBound(arr)
List.Add arr(i, 1)
Next
List.Sort
List.Reverse
m = 0
For Each k In List
m = m + 1
If Not d.exists(k) Then
d(k) = m
End If
Next
For i = 1 To UBound(arr)
s = arr(i, 1)
.Cells(i + 3, 29) = d(s)
Next
With .[a4].Resize(15, 29)
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

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

评分