VBA唯一值与图纸名称一起计数

您好，我正在检查工作簿中的每张工作表，并打印工作表的名称、每个唯一的项目以及它们的数量。但是我有一个错误，请帮助我。 这是一个广泛的例子的结果，我试图实现，现在我已经评论了

“表1”和“表2”
“Sheet1”Bob 23
“表1”标记1
“Sheet2”Ban 3
“Sheet2”Dan 2

我发现这行有一个错误：

---

我的代码为字典中的每个键存储一个ArrayList，以保存与该键关联的工作表名称列表。收集完所有数据后，它使用另一个ArrayList为每个键存储一个数组，

数组（工作表名称、键值、计数）

。它将该ArrayList中的数据提取到一个数组中，该数组将写入摘要工作表

Sub SummaryReport()
    Dim n As Long
    Dim dict As Object, list As Object, Target As Range, ws As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    Dim key As Variant, keyWSName As Variant, data As Variant

    For Each ws In ThisWorkbook.Worksheets
        With ws
            If Not .Name = "Summary" Then
                Set Target = .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                If Not Target Is Nothing Then
                    For n = 1 To Target.Count
                        key = Target.Cells(1)
                        If Trim(key) <> "" Then
                            If Not dict.exists(key) Then
                                dict.Add key, CreateObject("System.Collections.ArrayList")
                            End If
                            dict(key).Add ws.Name
                        End If
                    Next

                End If
            End If
        End With
    Next ws

    Set list = CreateObject("System.Collections.ArrayList")
    For Each key In dict
        For Each keyWSName In dict(key)
            list.Add Array(keyWSName, key, dict(key).Count)
        Next
    Next

    ReDim data(1 To list.Count, 1 To 3)
    For n = 0 To list.Count - 1
        data(n + 1, 1) = list(n)(0)
        data(n + 1, 2) = list(n)(1)
        data(n + 1, 3) = list(n)(2)
    Next

    With ThisWorkbook.Worksheets("Summary")
        .Columns("B:D").ClearContents
        .Range("B2:D2").Resize(list.Count).Value = data
    End With

End Sub

子摘要报告（）
长
Dim dict作为对象、列表作为对象、目标作为范围、ws作为工作表
Set dict=CreateObject（“Scripting.Dictionary”）
Dim键作为变量，keyWSName作为变量，数据作为变量
对于此工作簿中的每个ws。工作表
与ws
如果不是。Name=“Summary”则
设置目标=.Range（“B2”和.Range（“B”和.Rows.Count）.End（xlUp））
如果不是目标，那么什么都不是
对于n=1到Target.Count
key=Target.Cells（1）
如果微调（键）“，则
如果不存在dict.exists（键），则
dict.Add键，CreateObject（“System.Collections.ArrayList”）
如果结束
dict（key）.添加ws.Name
如果结束
下一个
如果结束
如果结束
以
下一个ws
Set list=CreateObject（“System.Collections.ArrayList”）
对于dict中的每个键
对于dict中的每个keyWSName（键）
添加数组（keyWSName，key，dict（key）.Count）
下一个
下一个
重拨数据（1到列表计数，1到3）
对于n=0的列表，计数为-1
数据（n+1，1）=列表（n）（0）
数据（n+1,2）=列表（n）（1）
数据（n+1,3）=列表（n）（2）
下一个
使用此工作簿。工作表（“摘要”）
.列（“B:D”）.清晰内容
.Range（“B2:D2”）.Resize（list.Count）。值=数据
以
端接头

此代码使用临时工作表和公式，而不是使用字典。
从每张纸上复制名称，删除重复项，然后应用

COUNTIF

公式进行计数。
然后复制最终图形，并将值粘贴到临时图纸的A列中

Sub Test()

    Dim wrkSht As Worksheet
    Dim tmpSht As Worksheet
    Dim rLastCell As Range
    Dim rTmpLastCell As Range
    Dim rLastCalculatedCell As Range

    'Add a temporary sheet to do calculations and store the list to be printed.
    Set tmpSht = ThisWorkbook.Worksheets.Add

   '''''''''''''''''''''''''''''''''''''''
   'Comment out the line above, and uncomment the next two lines
   'to print exclusively to the "Summary" sheet.
   '''''''''''''''''''''''''''''''''''''''
   'Set tmpSht = ThisWorkbook.Worksheets("Summary")
   'tmpSht.Cells.ClearContents

    For Each wrkSht In ThisWorkbook.Worksheets

        With wrkSht
            'Decide what to do with the sheet based on its name.
            Select Case .Name

                Case tmpSht.Name
                    'Do nothing
                Case Else 'Process sheet.

                    Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
                    'tmpSht.Columns(4).Resize(, 3).ClearContents

                    'Copy names to temp sheet and remove duplicates.
                    .Range(.Cells(1, 2), rLastCell).Copy Destination:=tmpSht.Cells(1, 5)
                    tmpSht.Columns(5).RemoveDuplicates Columns:=1, Header:=xlNo

                    'Calculate how many names appear on the sheet and place sheet name
                    'to left of people names.
                    Set rTmpLastCell = tmpSht.Cells(Rows.Count, 5).End(xlUp)
                    tmpSht.Range(tmpSht.Cells(1, 5), rTmpLastCell).Offset(, 1).FormulaR1C1 = _
                        "=COUNTIF('" & wrkSht.Name & "'!R1C2:R" & rLastCell.Row & "C2,RC[-1])"
                    tmpSht.Range(tmpSht.Cells(1, 5), rTmpLastCell).Offset(, -1) = wrkSht.Name

                    'Find end of list to be printed.
                    Set rLastCalculatedCell = tmpSht.Cells(Rows.Count, 1).End(xlUp).Offset(1)

                    'Copy columns D:F which contain the sheet name, person name and count.
                    'Paste at the end of column A:C
                    tmpSht.Range(tmpSht.Cells(1, 4), rTmpLastCell).Resize(, 3).Copy
                    rLastCalculatedCell.PasteSpecial xlPasteValues

                    'Clear columns D:F
                    tmpSht.Columns(4).Resize(, 3).ClearContents

            End Select

        End With

    Next wrkSht

End Sub

---

NextRowB

返回一个数字，因此

范围（NextRowB）

不正确。也许

范围（“B”&NextRowB）

？您好TinMan，谢谢您的帮助，但我总是遇到这个问题（注意我是VBA新手）。使用这一行：（和其他一些具有.Range的键）为.Range（“B2”、.Range（“B”&.Rows.Count）.End（xlUp））.Value获取应用程序定义的错误或对象定义的错误。您知道如何修复此问题吗？再次感谢TinMan，但我遇到了另一个错误（很抱歉，我对VBA非常陌生，不擅长调试）。对于Target.Value-->中的每个键，我都会得到Target.Value中每个键的类型不匹配错误。这是错误的精确行，在每张工作表中都有客户名称的文本值。我相信，在最后一行之前，页面中的客户名称数量不一。我得到了值1非常感谢您的帮助！，我还想知道是否可以在D列和E列的现有工作表上或在宏运行之后留下一个公式=如果（B7=”、“、COUNTIFS（间接（“、”B7&“！”、”B:B”）、”摘要（2）“！C7、间接（“、”B7&“！”、”Q:Q”），“我对VBA很陌生，如果这是一个愚蠢的问题，很抱歉！没有愚蠢的问题。当你说现有的表格时，你指的是摘要表格吗？公式有什么作用？我现在无法检查它&可能在接下来的12个小时内无法回答。我明白了Darren无论如何感谢所有的帮助！

Sub SummaryReport()
    Dim n As Long
    Dim dict As Object, list As Object, Target As Range, ws As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    Dim key As Variant, keyWSName As Variant, data As Variant

    For Each ws In ThisWorkbook.Worksheets
        With ws
            If Not .Name = "Summary" Then
                Set Target = .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                If Not Target Is Nothing Then
                    For n = 1 To Target.Count
                        key = Target.Cells(1)
                        If Trim(key) <> "" Then
                            If Not dict.exists(key) Then
                                dict.Add key, CreateObject("System.Collections.ArrayList")
                            End If
                            dict(key).Add ws.Name
                        End If
                    Next

                End If
            End If
        End With
    Next ws

    Set list = CreateObject("System.Collections.ArrayList")
    For Each key In dict
        For Each keyWSName In dict(key)
            list.Add Array(keyWSName, key, dict(key).Count)
        Next
    Next

    ReDim data(1 To list.Count, 1 To 3)
    For n = 0 To list.Count - 1
        data(n + 1, 1) = list(n)(0)
        data(n + 1, 2) = list(n)(1)
        data(n + 1, 3) = list(n)(2)
    Next

    With ThisWorkbook.Worksheets("Summary")
        .Columns("B:D").ClearContents
        .Range("B2:D2").Resize(list.Count).Value = data
    End With

End Sub

Sub Test()

    Dim wrkSht As Worksheet
    Dim tmpSht As Worksheet
    Dim rLastCell As Range
    Dim rTmpLastCell As Range
    Dim rLastCalculatedCell As Range

    'Add a temporary sheet to do calculations and store the list to be printed.
    Set tmpSht = ThisWorkbook.Worksheets.Add

   '''''''''''''''''''''''''''''''''''''''
   'Comment out the line above, and uncomment the next two lines
   'to print exclusively to the "Summary" sheet.
   '''''''''''''''''''''''''''''''''''''''
   'Set tmpSht = ThisWorkbook.Worksheets("Summary")
   'tmpSht.Cells.ClearContents

    For Each wrkSht In ThisWorkbook.Worksheets

        With wrkSht
            'Decide what to do with the sheet based on its name.
            Select Case .Name

                Case tmpSht.Name
                    'Do nothing
                Case Else 'Process sheet.

                    Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
                    'tmpSht.Columns(4).Resize(, 3).ClearContents

                    'Copy names to temp sheet and remove duplicates.
                    .Range(.Cells(1, 2), rLastCell).Copy Destination:=tmpSht.Cells(1, 5)
                    tmpSht.Columns(5).RemoveDuplicates Columns:=1, Header:=xlNo

                    'Calculate how many names appear on the sheet and place sheet name
                    'to left of people names.
                    Set rTmpLastCell = tmpSht.Cells(Rows.Count, 5).End(xlUp)
                    tmpSht.Range(tmpSht.Cells(1, 5), rTmpLastCell).Offset(, 1).FormulaR1C1 = _
                        "=COUNTIF('" & wrkSht.Name & "'!R1C2:R" & rLastCell.Row & "C2,RC[-1])"
                    tmpSht.Range(tmpSht.Cells(1, 5), rTmpLastCell).Offset(, -1) = wrkSht.Name

                    'Find end of list to be printed.
                    Set rLastCalculatedCell = tmpSht.Cells(Rows.Count, 1).End(xlUp).Offset(1)

                    'Copy columns D:F which contain the sheet name, person name and count.
                    'Paste at the end of column A:C
                    tmpSht.Range(tmpSht.Cells(1, 4), rTmpLastCell).Resize(, 3).Copy
                    rLastCalculatedCell.PasteSpecial xlPasteValues

                    'Clear columns D:F
                    tmpSht.Columns(4).Resize(, 3).ClearContents

            End Select

        End With

    Next wrkSht

End Sub