汇总分数的，帮改下代码

天涯887

汇总不了全部分数

ykcbf1100

得表来个效果图啊，靠猜不解决问题。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.10
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     For Each sht In Sheets
   
5.         If Val(sht.Name) Then
   
6.             With sht
   
7.                 r = .Cells(Rows.Count, 28).End(3).Row
   
8.                 arr = .[a1].Resize(r, 29).Value
   
9.             End With
   
10.             For i = 2 To UBound(arr) Step 3
    
11.                 s = arr(i + 1, 2) & "|" & arr(i + 1, 5) & "|" & arr(i + 2, 5)
    
12.                 d(s) = arr(i + 1, 28)
    
13.                 s = arr(i + 1, 2) & "|" & arr(i + 2, 5) & "|" & arr(i + 1, 5)
    
14.                 d(s) = arr(i + 2, 28)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     On Error Resume Next
    
19.     With Sheets("得")
    
20.         arr = .UsedRange
    
21.         For i = 1 To UBound(arr)
    
22.             If arr(i, 2) <> Empty And Val(arr(i, 1)) Then
    
23.                 For j = 3 To UBound(arr, 2) Step 4
    
24.                     s = arr(i, 2) & "|" & arr(i, j) & "|" & arr(i, j + 1)
    
25.                     .Cells(i, j + 2).Value = d(s)
    
26.                     s = arr(i, 2) & "|" & arr(i, j + 1) & "|" & arr(i, j)
    
27.                     .Cells(i, j + 3).Value = d(s)
    
28.                 Next
    
29.             End If
    
30.         Next
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

天涯887

ykcbf1100 发表于 2024-12-10 16:22
得表来个效果图啊，靠猜不解决问题。

图来了 如下图

天涯887

ykcbf1100 发表于 2024-12-10 16:50
附件供参考。。。

看新的附件，几号场 的工作表只许用到AP AQ AR AS 四列

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim d As Object
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For Each ws In Worksheets
   
8.         If ws.Name Like "*号场" Then
   
9.             With ws
   
10.                 r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
11.                 arr = .Range("a3:ab" & r)
    
12.                 For i = 1 To UBound(arr) Step 3
    
13.                     xm = arr(i, 5) & "+" & arr(i + 1, 5)
    
14.                     d(xm) = Array(arr(i, 28), arr(i + 1, 28))
    
15.                     xm = arr(i + 1, 5) & "+" & arr(i, 5)
    
16.                     d(xm) = Array(arr(i + 1, 28), arr(i, 28))
    
17.                 Next
    
18.             End With
    
19.         End If
    
20.     Next
    
21.     With Worksheets("得")
    
22.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
23.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
24.         arr = .Range("a1:ad" & r)
    
25.         For i = 1 To UBound(arr)
    
26.             For j = 3 To 23 Step 4
    
27.                 If Len(arr(i, j)) <> 0 And Len(arr(i, j + 1)) <> 0 Then
    
28.                     xm = arr(i, j) & "+" & arr(i, j + 1)
    
29.                     If d.exists(xm) Then
    
30.                         brr = d(xm)
    
31.                         arr(i, j + 2) = brr(0)
    
32.                         arr(i, j + 3) = brr(1)
    
33.                     End If
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
38.     End With
    
39. End Sub
    

复制代码

chxw68

参与一下。

ykcbf1100

天涯887 发表于 2024-12-10 17:16
看新的附件，几号场 的工作表只许用到AP AQ AR AS 四列

用新附件，代码不用改。

天涯887

昨天有点忙 今天回复下给予我帮助的朋友
我的本意 是想简化下代码 只根据和场地号的  AP AQ AR AS  这四列的数据 匹配到 得工作表中去，
只启用这四列 进行匹配，
还是谢谢大家了 分我随后送上