Vba 如何将类似的记录跨工作表分组？

我需要创建一个宏，帮助将来自多个工作表（实际上是6个工作表）的类似记录分组，并将结果放在汇总表中，列出所有找到的值

例如，我有两个月的时间。每张纸上都有这样的记录。每一张纸上都有可乐和可乐组合的独特记录。但在其他表格中，我可以找到相同的ColA-ColB组合，但ColC的值不同

表1 第2页 预期结果 如您所见，当我浏览其他表单时，可能会弹出新值，因此我需要添加它们，以指示前几个月的值为零。类似的情况是，当您在第一个表单中找到值时，其他表单中不存在该值

---

我只有几行代码只完成了工作的一部分，因此非常感谢您提供的任何帮助。

试试下面的代码-看起来有点混乱，但实际上有一种方法可以解决这种疯狂的问题。作为最后一步，如果您希望在目的地工作表中按字母顺序对结果进行排序，您可能需要在代码末尾添加一个排序例程

在运行之前，不要忘记在两个注释部分中输入图纸名称信息

Sub concat_values()

    Dim ws As Worksheet
    Dim dic As Object
    Dim wscoll As Collection
    Dim i As Integer
    Dim cell As Range

    Set wscoll = New Collection

    'Enter your source sheets names here
    wscoll.Add Worksheets("Sheet1")
    wscoll.Add Worksheets("Sheet2")
    wscoll.Add Worksheets("Sheet3")
    wscoll.Add Worksheets("Sheet4")
    wscoll.Add Worksheets("Sheet5")
    wscoll.Add Worksheets("Sheet6")

    Set dic = CreateObject("Scripting.Dictionary")
    n = 1

    For Each ws In wscoll

        For Each cell In ws.Range("A1:A" & ws.Range("A" & ws.Rows.count).End(xlUp).row).Cells

            mykey = cell.Value & "/" & cell.Offset(0, 1).Value

            If n >= 2 Then
                For j = 1 To n - 1
                    myval = myval & "0,"
                Next j
            End If

            myval = myval & cell.Offset(0, 2).Value

            If n <= wscoll.count - 1 Then
                For j = n To wscoll.count - 1
                    myval = myval & ",0"
                Next
            End If

            On Error GoTo ERREUR
            dic.Add mykey, myval
            On Error GoTo 0

            mykey = ""
            myval = ""

        Next cell
        n = n + 1

    Next ws

    i = 1

    'Enter your destination sheet name here
    With Worksheets("DEST")
        For Each k In dic.Keys
            .Range("A" & i).Value = Mid(k, 1, InStr(k, "/") - 1)
            .Range("B" & i).Value = Mid(k, InStr(k, "/") + 1, Len(k))
            .Range("C" & i).Value = dic(k)
            i = i + 1
        Next k
    End With

    Exit Sub

ERREUR:

    count = 1

    For j = 1 To n - 1
        count = InStr(count + 1, dic(mykey), ",")
    Next j

    dic(mykey) = WorksheetFunction.Replace(dic(mykey), count + 1, 1, cell.Offset(0, 2).Value)
    Resume Next

End Sub

---

好吧，你的问题是什么？@Sifu，没必要屈尊俯就。这个问题虽然不是一个真正的问题，但很明显。您需要问用户的正确问题是，到目前为止您所做的代码在哪里？诚然，就合并数据而言，您所期望的结果毫无意义。为什么在没有DDD1110 0的情况下，DDD的值是0,20？此外，请张贴您的代码。如果我们从零开始，我们将在这里拍摄空白。非常感谢，这项工作做得很好。我唯一需要考虑的是目标单元格的格式。切换到文本非常有效

ColA ColB ColC

AAA 111 2

CCC 222 50

DDD 111 20

ColA ColB ColC

AAA 111 2,2

BBB 111 3,0

CCC 222 50,50

DDD 111 0,20

Sub concat_values()

    Dim ws As Worksheet
    Dim dic As Object
    Dim wscoll As Collection
    Dim i As Integer
    Dim cell As Range

    Set wscoll = New Collection

    'Enter your source sheets names here
    wscoll.Add Worksheets("Sheet1")
    wscoll.Add Worksheets("Sheet2")
    wscoll.Add Worksheets("Sheet3")
    wscoll.Add Worksheets("Sheet4")
    wscoll.Add Worksheets("Sheet5")
    wscoll.Add Worksheets("Sheet6")

    Set dic = CreateObject("Scripting.Dictionary")
    n = 1

    For Each ws In wscoll

        For Each cell In ws.Range("A1:A" & ws.Range("A" & ws.Rows.count).End(xlUp).row).Cells

            mykey = cell.Value & "/" & cell.Offset(0, 1).Value

            If n >= 2 Then
                For j = 1 To n - 1
                    myval = myval & "0,"
                Next j
            End If

            myval = myval & cell.Offset(0, 2).Value

            If n <= wscoll.count - 1 Then
                For j = n To wscoll.count - 1
                    myval = myval & ",0"
                Next
            End If

            On Error GoTo ERREUR
            dic.Add mykey, myval
            On Error GoTo 0

            mykey = ""
            myval = ""

        Next cell
        n = n + 1

    Next ws

    i = 1

    'Enter your destination sheet name here
    With Worksheets("DEST")
        For Each k In dic.Keys
            .Range("A" & i).Value = Mid(k, 1, InStr(k, "/") - 1)
            .Range("B" & i).Value = Mid(k, InStr(k, "/") + 1, Len(k))
            .Range("C" & i).Value = dic(k)
            i = i + 1
        Next k
    End With

    Exit Sub

ERREUR:

    count = 1

    For j = 1 To n - 1
        count = InStr(count + 1, dic(mykey), ",")
    Next j

    dic(mykey) = WorksheetFunction.Replace(dic(mykey), count + 1, 1, cell.Offset(0, 2).Value)
    Resume Next

End Sub