Vba 链接两列中的条目

我在两列中有ID，比如A列和B列。在这些列中有ID，它们将在A或B中多次出现。我想做的是提供一个批次号，如下面的示例，其中任何相关ID都放在一个批次下

关于如何在excel/vba中实现这一点，有什么好主意吗？我有15000行。到目前为止，我已经尝试在每一行中循环，并尝试用2标记1，然后2到4等等，但是for循环突然变得几乎无限。我不在乎提供代码，更多的是逻辑方面

假设：

• 第一列始终包含起始链接
• 第二列始终包含链链接
• 若要继续链接链，必须稍后在第一列中找到第二列中列出的内容才能继续链接链（如示例所示）。这可以防止“链接拆分”，因为链接可以拆分为不同的链

如果这些假设为真，则此代码将适用于您：

Sub tgr()

    Const Link1Col As String = "A"
    Const Link2Col As String = "B"
    Const LinkIDCol As String = "C"

    Dim ws As Worksheet
    Dim linkColumns(1 To 2) As Range
    Dim FoundLink As Range
    Dim LinkID As Long
    Dim i As Long

    Set ws = ActiveWorkbook.ActiveSheet
    Set linkColumns(1) = ws.Range(Link1Col & "1", ws.Cells(ws.Rows.Count, Link1Col).End(xlUp))
    Set linkColumns(2) = Intersect(linkColumns(1).EntireRow, ws.Columns(Link2Col))

    Intersect(linkColumns(1).EntireRow, ws.Columns(LinkIDCol)).ClearContents
    LinkID = 0

    For i = linkColumns(1).Row To linkColumns(1).Row + linkColumns(1).Rows.Count - 1
        If Len(ws.Cells(i, LinkIDCol).Value) = 0 Then
            LinkID = LinkID + 1
            ws.Cells(i, LinkIDCol).Value = LinkID
            Set FoundLink = linkColumns(1).Find(ws.Cells(i, Link2Col).Value, , xlValues, xlWhole)
            If Not FoundLink Is Nothing Then
                Do
                    ws.Cells(FoundLink.Row, LinkIDCol).Value = LinkID
                    Set FoundLink = linkColumns(1).Find(ws.Cells(FoundLink.Row, Link2Col).Value, , xlValues, xlWhole)
                Loop While Not FoundLink Is Nothing
            End If
        End If
    Next i

End Sub

假设：

• 第一列始终包含起始链接
• 第二列始终包含链链接
• 若要继续链接链，必须稍后在第一列中找到第二列中列出的内容才能继续链接链（如示例所示）。这可以防止“链接拆分”，因为链接可以拆分为不同的链

如果这些假设为真，则此代码将适用于您：

Sub tgr()

    Const Link1Col As String = "A"
    Const Link2Col As String = "B"
    Const LinkIDCol As String = "C"

    Dim ws As Worksheet
    Dim linkColumns(1 To 2) As Range
    Dim FoundLink As Range
    Dim LinkID As Long
    Dim i As Long

    Set ws = ActiveWorkbook.ActiveSheet
    Set linkColumns(1) = ws.Range(Link1Col & "1", ws.Cells(ws.Rows.Count, Link1Col).End(xlUp))
    Set linkColumns(2) = Intersect(linkColumns(1).EntireRow, ws.Columns(Link2Col))

    Intersect(linkColumns(1).EntireRow, ws.Columns(LinkIDCol)).ClearContents
    LinkID = 0

    For i = linkColumns(1).Row To linkColumns(1).Row + linkColumns(1).Rows.Count - 1
        If Len(ws.Cells(i, LinkIDCol).Value) = 0 Then
            LinkID = LinkID + 1
            ws.Cells(i, LinkIDCol).Value = LinkID
            Set FoundLink = linkColumns(1).Find(ws.Cells(i, Link2Col).Value, , xlValues, xlWhole)
            If Not FoundLink Is Nothing Then
                Do
                    ws.Cells(FoundLink.Row, LinkIDCol).Value = LinkID
                    Set FoundLink = linkColumns(1).Find(ws.Cells(FoundLink.Row, Link2Col).Value, , xlValues, xlWhole)
                Loop While Not FoundLink Is Nothing
            End If
        End If
    Next i

End Sub

---

这是对我10月18日发布的代码10月19日的一次修改，该代码有一个严重的bug和一些其他故障。希望这个版本更有效。我在这篇文章的末尾写了一个关于这个bug的注释

此解决方案使用一个类cGroup，它表示组的标识符，其中组定义为列a和列B中出现在同一行上的所有字符串。因此，组的成员资格意味着在工作表的某个位置有一行，该行上有两个相同组的成员，并且其中至少一个成员也出现在列表中的另一行上（除非两个值在同一行上只出现一次，并且它们有自己的组）。每个组都有一个原始的类ID，创建时会分配给它，但以后可能会链接到另一个父组（见下文），在这种情况下，它会采用其父组的类ID

该代码沿着列表向下运行，并将列A和列B中的键值分配给预先存在的组（如果其中一个键以前出现在列表中）。如果两个组之前都没有出现过，那么将为它们创建一个具有新类ID的新组。如果它们以前都出现在不同的行上，并且被分配到不同的组，则必须链接这些组。这是通过选择一个组作为另一个组的父组来实现的，然后该组可以形成子级>父级关系的层次结构。子组采用其父组的classID-classID属性包含此项的逻辑。这种方法的最大优点是，它避免了大规模迭代，尽管在child>Parent ClassID层次结构上仍然存在迭代，以发现层次结构中较低的子级的ClassID

我使用Scripting.Dictionary提供从键到其类的查找。要在代码中使用它，请在“工具”>“引用”中设置对Microsoft脚本运行时库的引用

我已经实现了将关键数据作为一个单独的类cGroup进行处理的代码，该代码使用一个方法AllocateClassis，该方法在工作表中有一个3列区域进行处理，这三列分别是前两列每行上的KeyA、KeyB输入和第三列中相应的输出类号。要使用此类，代码如下所示：

Public Sub run()

    Dim oGrouper As New cGrouper

    '// rTestData1 is a named range in the a worksheet that is 3 columns x n rows, containing n pairs of keys
    '// in col1 and col2. the allocated class number is written into column 3 of the range
    oGrouper.AllocateClassIDs [rTestData1]

End Sub

以下是cGroup类的代码：

Option Explicit
'// This class will identify groups of related key values in two Key columns of a worksheet and then assign group numbers.
'// A group is defined as the set of Keys that appear on the same rows in the two key columns. So if A and B are on
'// row 3 and B and C on row 4, then A, B and C are in the same group, along with any other key values that share
'// the same relationship with each other.

'// Corollary: Keys are in different goups only if each key in the group never appears on the same row as any of the keys in any other group



'// Dictionaries
'// Lookup from a key value to the related class. Key value is a string that appears in colA or colB
Dim GroupMembers As New Scripting.Dictionary

'// Lookup to the groups that have already been created. The key is the GroupGroupID (integer assigned on creation)
Dim Groups As New Scripting.Dictionary


'// This subroutine does all the work
    Public Sub AllocateClassIDs(Keys As Range)

        '// First clear out the dictionaries
        GroupMembers.RemoveAll
        Groups.RemoveAll

        g.Reset

        '// Check the given ranges
        If Keys.Columns.Count <> 3 Then
            MsgBox "Range must have three columns - cannot process"
            Exit Sub
        End If

        '// Set up references to the sub-ranges within the sheet
        Dim KeysA As Range, KeysB As Range, ClassIDs As Range

        Set KeysA = Keys.Columns(1)
        Set KeysB = Keys.Columns(2)
        Set ClassIDs = Keys.Columns(3)



        Dim iRow As Integer, sAKey As String, sBKey As String
        Dim iAGroup As cGroup, iBGroup As cGroup

        '// Run down every row of the given range
        For iRow = 1 To KeysA.Rows.Count

            '// Get the key values from Col A and Col B
            sAKey = KeysA.Cells(iRow)
            sBKey = KeysB.Cells(iRow)

            '// Check if these keys have already been found earlier
            If GroupMembers.Exists(sAKey) Then Set iAGroup = GroupMembers.Item(sAKey) Else Set iAGroup = Nothing
            If GroupMembers.Exists(sBKey) Then Set iBGroup = GroupMembers.Item(sBKey) Else Set iBGroup = Nothing


            '// Now check the combination of possibilities:
            Select Case True
                Case iAGroup Is Nothing And iBGroup Is Nothing

                    '// Neither key was found so we need to create a new group to hold the class number
                    If Len(sAKey) > 0 Or Len(sBKey) > 0 Then
                        With New cGroup
                            '// Add the group to the dictionary of groups
                             Groups.Add .GroupID, .Self

                            '// Add the keys to the dictionary of group members. This links the key to the group
                            If Len(sAKey) > 0 Then GroupMembers.Add sAKey, .Self
                            If sAKey <> sBKey And Len(sBKey) > 0 Then GroupMembers.Add sBKey, .Self
                        End With
                    End If
                Case iBGroup Is Nothing
                    '// Key in col A is already in a group from an earlier line, but key in Col B is not
                    '// we just add ColB key to the same group as the col A key
                    If Len(sBkey)>0 Then
                        Set iAGroup = GroupMembers.Item(sAKey)
                        GroupMembers.Add sBKey, iAGroup
                    End If

                Case iAGroup Is Nothing
                    '// Key in Col B is already in a group, but Key in col A is not
                    '// We just add ColA key to the same group as the col B key
                    IF Len(sAkey)>0 Then
                        Set iBGroup = GroupMembers.Item(sBKey)
                        GroupMembers.Add sAKey, iBGroup
                    End IF


                Case Else
                    '// They are both already in a group. That's fine if they are members of the same class but...
                    If iAGroup.ClassID <> iBGroup.ClassID Then

                        '// They are in DIFFERENT Classes so we must merge them together by settung
                        '// the class ID of one group to be the same as the other

                            '// Always use the lower-numbered class ID
                            If iAGroup.ClassID < iBGroup.ClassID Then
                                iBGroup.JoinGroupMembership iAGroup
                            Else
                                iAGroup.JoinGroupMembership iBGroup
                            End If


                    End If
                End Select

        Next iRow


        '// Remember the last row
        Dim iLastRow As Integer: iLastRow = iRow - 1

        '// Assign the class numbers. This just makes sure each unique class has a number, starting at 1.
        Dim ClassNumbers As New Scripting.Dictionary
        Dim ix As Integer

        Dim iGroup As cGroup
        Dim iClassNumber As Integer

        For ix = 0 To Groups.Count - 1
            '// Get the next group object
            Set iGroup = Groups.Item(Groups.Keys(ix))

            '// Check if this is a "ROOT" group, i.e. the group ID is the same as the class ID
            If iGroup.bIsRootGroup Then
                iClassNumber = iClassNumber + 1
                'If iClassNumber = 30 Then MsgBox "Classnumber 30"

                '// Add it to the dictionary of class numbers
                ClassNumbers.Add iGroup.ClassID, iClassNumber
            End If

        Next ix

        '// Finally, we can assign the class numbers to the rows in the spreadsheet
        Application.Calculation = xlCalculationManual

        For ix = 1 To iLastRow

            '// Put the relevant class number into column 3
            ClassIDs.Cells(ix) = ClassNumbers.Item(GroupMembers.Item(KeysA.Cells(ix).Value).ClassID)

        Next ix
         Application.Calculation = xlCalculationAutomatic

        MsgBox "done"

    End Sub

这是我命名为g的模块的代码

    Option Explicit

    '// Global register of Group ID
    Private gMaxGroupNumber As Integer

    '// Method to get the next available GroupID
    Public Function NextGroupID() As Integer
        gMaxGroupNumber = gMaxGroupNumber + 1
        NextGroupID = gMaxGroupNumber

    End Function

    '// Method to reset the groupID
    Public Sub Reset()
        gMaxGroupNumber = 0

    End Sub

---

---

关于bug：在我早期版本的代码中，组层次结构不起作用，因为它只是将父classID简单地分配给一个组。只要两组以受控顺序连接，这是可以的，但如果已经形成了两个独立的组，随后，两个组的合并序列可以隔离以前链接的成员-它们的ClassID没有用新的父类更新，因此它们实际上是孤立的。

这是10月19日对我10月18日发布的代码的修改，该代码有一个严重的错误和一些其他故障。希望这个版本更有效。我在这篇文章的末尾写了一个关于这个bug的注释

此解决方案使用一个类cGroup，它表示组的标识符，其中组定义为列a和列B中出现在同一行上的所有字符串。因此，组的成员资格意味着在工作表的某个位置有一行，该行上有两个相同组的成员，并且其中至少一个成员也出现在列表中的另一行上（除非两个值在同一行上只出现一次，并且它们有自己的组）。每个组都有一个原始的类ID，创建时会分配给它，但以后可能会链接到另一个父组（见下文），在这种情况下，它会采用其父组的类ID

该代码沿着列表向下运行，并将列A和列B中的键值分配给预先存在的组（如果其中一个键以前出现在列表中）。如果两个组之前都没有出现过，那么将为它们创建一个具有新类ID的新组。如果它们以前都出现在不同的行上，并且被分配到不同的组，则必须链接这些组。这是通过选择一个组作为另一个组的父组来实现的，然后该组可以形成子级>父级关系的层次结构。子组采用其父组的classID-classID属性包含此项的逻辑。这种方法的最大优点是它避免了大规模的迭代，尽管在child>Parent ClassID层次结构上仍然有迭代来发现子级的ClassID