求多表合并汇总统计

willem168

请各路大神帮忙处理一下这个合并（注意：合计 有计数 和 合计 区分）

沈默00

沈默00

问题也不复杂，就是表格这样子有点不好处理，，试一下吧，结果和你模拟的有点不一样，

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.6
   
2.     Application.ScreenUpdating = False
   
3.     ReDim brr(1 To 10000, 1 To 11)
   
4.     Set sh = ThisWorkbook.Sheets("汇总统计")
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             m = m + 1
   
8.             With sht
   
9.                 brr(m, 1) = .Name
   
10.                 r = .Cells(Rows.Count, 1).End(3).Row
    
11.                 r1 = .UsedRange.Find("B仓库", LookIn:=xlValues).Row
    
12.                 arr = .UsedRange
    
13.                 p1 = 0: n = 0
    
14.                 For i = 3 To r1 - 3
    
15.                     p1 = p1 + IIf(arr(i, 11) = "不合格", arr(i, 10), 0)
    
16.                     n = n + IIf(arr(i, 11) = "不合格", 1, 0)
    
17.                 Next
    
18.                 brr(m, 2) = r1 - 5
    
19.                 brr(m, 3) = arr(r1 - 2, 10)
    
20.                 brr(m, 4) = arr(r1 - 2, 8)
    
21.                 brr(m, 5) = p1
    
22.                 brr(m, 6) = n
    
23.                 p1 = 0: n = 0
    
24.                 For i = r1 + 2 To r - 2
    
25.                     p1 = p1 + IIf(arr(i, 11) = "不合格", arr(i, 10), 0)
    
26.                     n = n + IIf(arr(i, 11) = "不合格", 1, 0)
    
27.                 Next
    
28.                 brr(m, 7) = r - 3
    
29.                 brr(m, 8) = arr(r - 1, 10)
    
30.                 brr(m, 9) = arr(r - 1, 8)
    
31.                 brr(m, 10) = p1
    
32.                 brr(m, 11) = n
    
33.             End With
    
34.         End If
    
35.     Next
    
36.     With sh
    
37.         .UsedRange.Offset(1).ClearContents
    
38.         .[a2].Resize(m, 11) = brr
    
39.     End With
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    
43. 
    

复制代码

willem168

Sub bz()
Dim h1 As Long
Dim h2 As Long
Dim h3 As Long
Dim h4 As Long
Dim hr1 As Range
Dim hr2 As Range
Dim hr3 As Range
Dim hr4 As Range

   Set hr1 = Range("p:p").Find(What:="检验结果", LookIn:=xlValues, LookAt:=xlWhole)
   Set hr3 = Range("p:p").FindNext(hr1)
   Set hr2 = Range("A:b").Find(What:="A合计：", LookIn:=xlValues, LookAt:=xlWhole)
   Set hr4 = Range("A:b").Find(What:="B合计：", LookIn:=xlValues, LookAt:=xlWhole)
   
h1 = hr1.Row
h2 = hr2.Row
h3 = hr3.Row
h4 = hr4.Row
       wms = 0 '检验计数
        For hi = 1 To h2 - 1 - h1

           If InStr(1, Cells(h1 + hi, 16).Value, "检验", vbTextCompare) > 0 Then '“检验”下一行开始循环
            h = Cells(h1 + hi, 9)
            'Debug.Print h
            wms = wms + Cells(h1 + hi, 6)
             wmhj = wmhj + Cells(h1 + hi, 9) '检验合计
           

           
           End If


      Next
'''''''''''''''''''''''''''''''''''''
      wms2 = 0 '检验计数
        For hi2 = 1 To h4 - 1 - h3

           If InStr(1, Cells(h3 + hi2, 16).Value, "检验", vbTextCompare) > 0 Then '“检验”下一行开始循环
           ' h = Cells(h3 + hi2, 9)
            'Debug.Print h
            wms2 = wms2 + Cells(h3 + hi2, 6) 'wms2 + 1
             wmhj2 = wmhj2 + Cells(h3 + hi2, 9) '检验合计
           

           
           End If


      Next

           Debug.Print wms
           Debug.Print wmhj2
'Debug.Print h3
End Sub
感谢各位大神 我自己处理了一下 这只是一个思路 我自己的需求表和发出的略有出入 只做思路参考

willem168

ykcbf1100 发表于 2024-4-6 14:46
附件供参考。。。

感谢老师 的修改

沈默00

ykcbf1100 发表于 2024-4-6 14:47
参与一下。。。

草爷的这个IIF用的好，我用的太少了，，，要学习一下

沈默00

willem168 发表于 2024-4-6 15:07
Sub bz()
Dim h1 As Long
Dim h2 As Long

建议尽量少用一些单元格的代码，这们数据多了会影响运行速度，完全可以用数组或字典处理

ykcbf1100

沈默00 发表于 2024-4-6 16:51
草爷的这个IIF用的好，我用的太少了，，，要学习一下

多用用就好了。