多列计数统计

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:m" & r)
   
7.         For j = 1 To UBound(arr, 2)
   
8.             If arr(1, j) <> "液位" And arr(1, j) <> "压力" Then
   
9.                 arr(2, j) = 0
   
10.                 arr(3, j) = 0
    
11.                 arr(4, j) = 0
    
12.                 m = 0
    
13.                 For i = 5 To UBound(arr)
    
14.                     Select Case arr(i, j)
    
15.                         Case "运行"
    
16.                             m = 2 '
    
17.                         Case "停止"
    
18.                             m = 3
    
19.                         Case "故障"
    
20.                             m = 4
    
21.                     End Select
    
22.                     If m <> 0 Then
    
23.                         arr(m, j) = arr(m, j) + 1
    
24.                     End If
    
25.                 Next
    
26.                 arr(2, j) = "运:" & arr(2, j)
    
27.                 arr(3, j) = "停:" & arr(3, j)
    
28.                 arr(4, j) = "障:" & arr(4, j)
    
29.             End If
    
30.         Next
    
31.         .Range("a2:m" & r) = arr
    
32.     End With
    
33.    
    
34.    
    
35. End Sub
    

复制代码

ykcbf1100

lgzxmlg 发表于 2023-5-5 20:01
表格中公式还在。不知是何原因。

我再看一下吧。
我看了一下，确实有点问题。先不要用我的代码了。

chxw68

参与一下。

lgzxmlg

chxw68 发表于 2023-5-5 20:40
参与一下。

理想，谢谢。

cyq4896

试试这个代码。


Sub h0()
    Dim i%, j%, k%, arr, brr, ss$, n%
    arr = [A1].CurrentRegion
    For j = 1 To Cells(2, Columns.Count).End(xlToLeft).Column
        If Cells(2, j) <> "液位" And Cells(2, j) <> "压力" Then
            For i = 3 To 5
                ss = Split(arr(i, j), ":")(0)
                n = 0
                For k = 6 To UBound(arr)
                    If InStr(arr(k, j), ss) Then n = n + 1
                Next
                arr(i, j) = ss & ":" & n
            Next
        End If
    Next
    [A1].CurrentRegion = arr
End Sub

cyq4896

Sub h0()
    Dim i%, j%, k%, arr, brr, ss$, n%
    arr = [A1].CurrentRegion
    For j = 1 To Cells(2, Columns.Count).End(xlToLeft).Column
        If Cells(2, j) <> "液位" And Cells(2, j) <> "压力" Then
            For i = 3 To 5
                ss = Split(arr(i, j), ":")(0)
                n = 0
                For k = 6 To UBound(arr)
                    If InStr(arr(k, j), ss) Then n = n + 1
                Next
                arr(i, j) = ss & ":" & n
            Next
        End If
    Next
    [A1].CurrentRegion = arr
End Sub

cyq4896

Sub h0()
    Dim i%, j%, k%, arr, brr, ss$, n%
    arr = [A1].CurrentRegion
    For j = 1 To ubound(arr,2)
        If arr(2, j) <> "液位" And arr(2, j) <> "压力" Then
            For i = 3 To 5
                ss = Split(arr(i, j), ":")(0)
                n = 0
                For k = 6 To UBound(arr)
                    If InStr(arr(k, j), ss) Then n = n + 1
                Next
                arr(i, j) = ss & ":" & n
            Next
        End If
    Next
    [A1].CurrentRegion = arr
End Sub

ykcbf1100

还是参与一下吧。

全党

参与一下，练练手。。。。。。。。。

1. Sub shishi()
   
2. Dim rng As Range
   
3. arr = Range("a1:m5").Value
   
4. brr = [{"运行","停止","故障"}]
   
5. For i = 1 To UBound(arr, 2)
   
6.    If arr(2, i) <> "液位" And arr(2, i) <> "压力" Then
   
7.    rn = Cells(Rows.Count, i).End(xlUp).Row
   
8.    sn = 0
   
9.    For j = 1 To UBound(brr)
   
10.    Set rng = Range(Cells(6, i), Cells(rn, i))
    
11.    sn = WorksheetFunction.CountIf(rng, brr(j))
    
12.    arr(j + 2, i) = Left(brr(j), 1) & ":" & sn
    
13.    sn = 0
    
14.    Next
    
15.    End If
    
16. Next
    
17. Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
18. End Sub

复制代码

全党

用字典做一个。。。。。。。。。。。。。

1. Sub 宏1()
   
2. Set dic = CreateObject("scripting.dictionary")
   
3.     rn = Cells(Rows.Count, 13).End(xlUp).Row
   
4.     arr = Range("a1:m" & rn).Value
   
5.     Range("A3:M5").ClearContents
   
6.     br = Array("运", "停", "故")
   
7. For i = 1 To UBound(arr, 2)
   
8.    If arr(2, i) <> "液位" And arr(2, i) <> "压力" Then
   
9.    For j = 6 To UBound(arr)
   
10.     If arr(j, i) <> "" Then
    
11.     dic(Left(arr(j, i), 1)) = dic(Left(arr(j, i), 1)) + 1
    
12.     End If
    
13.    Next
    
14.    End If
    
15. For k = 0 To UBound(br)
    
16. arr(k + 3, i) = br(k) & ":" & dic(br(k))
    
17. Next
    
18. dic.RemoveAll
    
19. Next
    
20. [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
21. End Sub

复制代码