求大神增加VBA计数功能

xxxxbbhiox

Sub TEST()
        Application.ScreenUpdating = False
    With Sheet1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        r = .Cells(Rows.Count, "b").End(xlUp).Row
        If r = 1 Then MsgBox "没有数据不能使用", 64, "提示": Exit Sub
        arr = .Range("b2:f" & r)
    End With
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        If Len(arr(i, 1)) Then
             dic(arr(i, 1) & "+" & arr(i, 4)) = dic(arr(i, 1) & "+" & arr(i, 4)) + 1
            If d.exists(arr(i, 1) & "+" & arr(i, 4)) = False Then
                d(arr(i, 1) & "+" & arr(i, 4)) = arr(i, 2) & "#" & arr(i, 5)
            Else
                d(arr(i, 1) & "+" & arr(i, 4)) = d(arr(i, 1) & "+" & arr(i, 4)) & "@" & arr(i, 2) & "#" & arr(i, 5)
            End If
        End If
    Next
   icount = Application.Max(dic.items)
   ReDim brr(1 To d.Count, 1 To icount * 2 + 4)
   tem = d.keys
   tem2 = d.items
   For i = 0 To UBound(tem)
        brr(i + 1, 1) = Split(tem(i), "+")(0)
        brr(i + 1, 2) = Split(tem(i), "+")(1)
        tem3 = Split(tem2(i), "@")
        For x = 0 To UBound(tem3)
            brr(i + 1, x * 2 + 5) = Split(tem3(x), "#")(0)
            brr(i + 1, x * 2 + 6) = Split(tem3(x), "#")(1)
            Total = Total + Val(brr(i + 1, x * 2 + 6))
        Next
        brr(i + 1, 4) = Total
        Total = 0
   Next
   With Sheet2
        r = .Cells(Rows.Count, "A").End(xlUp).Row
        If r > 1 Then .Range(.Cells(2, 2), .Cells(r, 242)).ClearContents
        .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
        MsgBox "运行完成", 64, "提示"
        Set dic = Nothing: Set d = Nothing
   End With
       Range(Selection, Selection.End(xlDown)).Select
    Rows("2:328").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
    Rows("2:2006").Select
                Range("c2").Select

求助详细, 在目标工作表的C列实现计数功能(每一行的数量个数作为计数结果)

xxxxbbhiox

求助 C列实现计数功能,谢谢!

opel-wong

xxxxbbhiox 发表于 2019-9-5 20:18
求助 C列实现计数功能,谢谢!

没有附件，谁也搞不定啊，

xxxxbbhiox

opel-wong 发表于 2019-9-5 22:04
没有附件，谁也搞不定啊，

大神，这是附件，请看一下

xxxxbbhiox

xxxxbbhiox 发表于 2019-9-6 07:28
大神，这是附件，请看一下

opel-wong 发表于 2019-9-5 22:04
没有附件，谁也搞不定啊，

大神，这是附件，请看一下

批号领匹配分色号表(计数)

xxxxbbhiox

批号领匹配分色号表(计数)  这是附件

xxxxbbhiox

大神，这是附件，请看一下

请大神解决VBA计数功能

蓝桥玄霜

表格附件没有上传成功？

xxxxbbhiox

蓝桥玄霜 发表于 2019-9-6 08:29
表格附件没有上传成功？

对，不知道怎么回事，附件上传了N遍了，就是不能上传，大神这是什么问题