EXCEL VBA统计的代码？

Posted 2023-03-19

E:G的数字(个位数0-9),对比H1:P1的数字(2位数,不重复的数值),如果H1:P1的数字在E:G里面包含了2个,那么就在H9开始对应的位置返回2,如是包含其它的数量就不需要返回;返回就从H9开始到P列,行数是E列不为空的行数;这是1张工作表的情况,工作表一共有"断断"和"1","2"…….一直到"20",共21个,都是一样的位置和格式;因为公式太大太慢了,所以请问这个代码用数组或字典的快速方法怎么写啊?求各位大师帮忙写一下.

测试数据表：

程序代码图：

执行效果：

程序文本：

Option Explicit

Sub 宏1()

    Dim a(), d(1 To 9) As Object, e(), h(), i&, j&, n&, st As Worksheet

    For Each st In Sheets \'对所有工作表

        If st.Name <> "开奖数据" Then

            \'切换表，并获取内容到数组中

            st.Activate

            \'参数区处理：建立字典，1-9表示H-P的列号

            a = st.Range("h1:p1")

            For i = 1 To UBound(a, 2)

                If Not d(i) Is Nothing Then

                    d(i).RemoveAll

                Else

                    Set d(i) = CreateObject("Scripting.Dictionary")

                End If

                a(1, i) = Trim(a(1, i))

                For j = 1 To Len(a(1, i))

                    d(i)(Mid(a(1, i), j, 1)) = 1

                Next j

            Next i

            \'数据区处理

            n = st.Cells(st.Rows.Count, "e").End(xlUp).Row \'E列最后一行行号

            If n >= 9 Then \'跳过不足9行的表

                e = st.Range(st.Cells(9, "e"), st.Cells(n, "g")) \'E:G - 源数组

                h = st.Range(st.Cells(9, "h"), st.Cells(n, "p")) \'H:P - 结果数组

                For i = 1 To UBound(e)

                    For j = 1 To 3

                        e(i, j) = Trim(e(i, j))

                    Next j

                    If e(i, 1) <> "" And e(i, 2) <> "" And e(i, 3) <> "" Then

                        For j = 1 To UBound(a, 2)

                            If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) >= 2 Then

                                h(i, j) = 2

                            Else

                                h(i, j) = Empty

                            End If

                        Next j

                    End If

                Next i

                \'数组回写表

                With st.Range(st.Cells(9, "h"), st.Cells(n, "p"))

                    .Select

                    .Value = h

                End With

            End If

        End If

    Next st

End Sub

追问

谢谢老师,终于等到你了.
有个小问题,我把这句改成了 If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) = 0 Then
h(i, j) = 0
这个时候,如果H:P列中有一列是全空的,那么怎么判断不在这一列返回0呢.我试了几次加不好.

追答

If d(j)(e(i, 1)) + d(j)(e(i, 2)) + d(j)(e(i, 3)) = 0 Then
if a(1,j)"" then h(i, j) = 0 else h(i,j)=empty

追问

老师,这个代码我想改一下,改成源数组和结果数组都是1列的情况,这个源数组老是改不好,我发了个新问,您再帮我看一下.

参考技术A

Rem 方法一

Rem 在单元格H9中输入“=CNT($E9:$G9,H$1)”,填充单元格

Public Function CNT(rngV, rngH) 'rngV为E:G,rngH为H1:P1

    Dim a, b

    a = Left(rngH, 1) + 0

    b = Right(rngH, 1) + 0 'rngH分割十位个位，文本转为数值

    CNT = 0

    For Each i In rngV

        If i = a Then CNT = CNT + 1

        If i = b Then CNT = CNT + 1

    Next

    If CNT <> 2 Then CNT = 0 '结果部位2时返回0

End Function

---

Rem 方法二

Rem 执行a过程

Sub CNTs(rngV, rngH, rngR) 'rngV为E:G,rngH为H1:P1,rngR返回区域

    Dim RR, CC, arr, brr

    RR = rngR.Rows.Count '行数

    CC = rngR.Columns.Count '列数

    ReDim arr(1 To CC), brr(1 To CC)'重设数组列数

    Rem rngH分割十位个位，文本转为数值

    For i = 1 To CC

        arr(i) = Left(rngH(i), 1) + 0

        brr(i) = Right(rngH(i), 1) + 0

    Next

    

    ReDim CNTs(1 To RR, 1 To CC)'重设结果数组大小

    Rem 对比计数

    For r = 1 To RR

        For c = 1 To CC

            For Each i In Array(rngV(r, 1), rngV(r, 2), rngV(r, 3))

                If i = arr(c) Then CNTs(r, c) = CNTs(r, c) + 1

                If i = brr(c) Then CNTs(r, c) = CNTs(r, c) + 1

            Next

        Next

    Next

    For r = 1 To RR

        For c = 1 To CC

            If CNTs(r, c) <> 2 Then CNTs(r, c) = 0 '结果部位2时返回0

        Next

    Next

    Rem 导出结果

    Range(rngR.Address) = CNTs

End Sub

Sub a()

    'CNTs(rngV, rngH, rngR)rngV为E:G,rngH为H1:P1,rngR返回区域

    Call CNTs(Range("A3:c10"), Range("m1:u1"), Range("m3:u10"))

End Sub

参考技术B 公式肯定不行了，数据多就卡了
写代码是可以处理