求助各位老师用VBA实现多表格汇总，AI搞了半天没成功

ykcbf1100

写了一个线别的汇总，操作人汇总小改一下就可以了，就没写。

不良率计算公式感觉有问题，就没动。
附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.18
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 1)
   
6.     For Each sht In Sheets
   
7.         If Val(sht.Name) Then
   
8.             With sht
   
9.                 r = .Cells(Rows.Count, 1).End(3).Row
   
10.                 arr = .[a1].Resize(r, 19)
    
11.             End With
    
12.             For i = 2 To UBound(arr)
    
13.                 If Val(arr(i, 5)) <> 0 Then
    
14.                     s = arr(i, 1)
    
15.                     If Not d1.exists(s) Then
    
16.                         m = m + 1
    
17.                         d1(s) = m
    
18.                         brr(m, 1) = s
    
19.                     End If
    
20.                     For j = 4 To 5
    
21.                         s = arr(i, 1) & "|" & arr(4, j)
    
22.                         d(s) = d(s) + arr(i, j)
    
23.                     Next
    
24.                     For j = 7 To 19
    
25.                         s = arr(i, 1) & "|" & arr(5, j)
    
26.                         d(s) = d(s) + arr(i, j)
    
27.                     Next
    
28.                 End If
    
29.             Next
    
30.         End If
    
31.     Next
    
32.     With Sheets("汇总")
    
33.         .[a2:a15] = ""
    
34.         .[a2].Resize(m, 1) = brr
    
35.         .[a2].Resize(m, 1).Sort .[a2], 1
    
36.         arr = .[a1:p16].Value
    
37.         For i = 2 To UBound(arr)
    
38.             For j = 2 To 15
    
39.                 s = arr(i, 1) & "|" & arr(1, j)
    
40.                 If d.exists(s) Then
    
41.                     arr(i, j) = d(s)
    
42.                 End If
    
43.             Next
    
44.         Next
    
45.         .[a1:p16].Value = arr
    
46.         For i = 2 To UBound(arr)
    
47.             .Cells(i, 16).Value = Application.Sum(.Cells(i, 2).Resize(, 14))
    
48.             If .Cells(i, 2).Value <> 0 Then
    
49.                 .Cells(i, 17).Value = .Cells(i, 16).Value / .Cells(i, 2).Value / 100
    
50.             Else
    
51.                 .Cells(i, 17).Value = ""
    
52.             End If
    
53.         Next
    
54.         For j = 2 To 16
    
55.             .Cells(16, j).Value = Application.Sum(.Cells(2, j).Resize(m))
    
56.         Next
    
57.         ActiveWindow.DisplayZeros = False
    
58.     End With
    
59.     Set d = Nothing
    
60.     Set d1 = Nothing
    
61.     Application.ScreenUpdating = True
    
62.     MsgBox "OK！"
    
63. End Sub
    
64. 
    

复制代码

lixinlin181818

ykcbf1100 发表于 2024-9-18 18:46
参与一下。。。

谢谢老师，中午回去试试