Question

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

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

Answer 1

这是我在18Oct上发布的代码的19Oct的修改，其中有一个严重的错误和一些其他的失败。希望这个版本更有效。我在这篇文章的末尾写了一篇关于这个bug的说明。

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

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

我使用Scripting.Dictionary提供从键到其类的查找。要在代码中使用它，请在工具＆gt;中设置对Microsoft Scripting Runtime库的引用。引用。

我已经实现了将关键数据作为单独的类cGrouper处理的代码，该方法使用单个方法AllocateClassIDs，它给出了要处理的工作表的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

以下是cGrouper类的代码：

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

这是cGroup Class的代码

    Option Explicit

    '// Properties of the class
    Public GroupID As Integer

    '// The group master of this class (i.e. another group to which it has been joined)
    '// Can be Nothing if not joined to any other group or if this is the master group 
    '// of a set of joined groups
    Private memberOfGroup As cGroup


    Private Sub class_initialize()
        '// Assign an ID to myself
        GroupID = g.NextGroupID

        '// I am not a member of any other group
        Set memberOfGroup = Nothing

    End Sub

    Public Sub JoinGroupMembership(NewLinkedGroup As cGroup)
        '// Links this group to membership of another group.
        '// Note that this group may already be a member of another group, in which case
        '// group membership is changed on the parent group as well as this group

        '// To avoid circular references, the group with the lower classid is always chosen to be the parent

        If NewLinkedGroup.ClassID > Me.ClassID Then
            NewLinkedGroup.JoinGroupMembership Me
            Exit Sub
        End If

        '// If I am already member of a group, make sure my parent group
        '// joins the new group
        If Not memberOfGroup Is Nothing Then
            memberOfGroup.JoinGroupMembership NewLinkedGroup
        End If

        '// Now set the new linked group to be my parent
        Set memberOfGroup = NewLinkedGroup


    End Sub


    Public Function ClassID() As Integer
    '// Returns the classID of this group's master group
    '// Note that this is recursive, it will work up through the hierarchy of
    '// parent groups until it hits the group with no parent.


        '// Check if I am the master group
        If memberOfGroup Is Nothing Then
            '// Return my GroupID as the classID
            ClassID = GroupID
        Else
            '// Return the classID of my parent
            ClassID = memberOfGroup.ClassID
        End If

    End Function

    Public Function bIsRootGroup() As Boolean
    '// Returns true if this group is not a member of another group
        bIsRootGroup = memberOfGroup Is Nothing
    End Function

    Public Function Self() As cGroup
        Set Self = Me

    End Function

这是我命名为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

关于错误：在我的早期版本的代码中，组层次结构不起作用，因为它是将父classID简单分配给组。只要这些组以受控序列连接就可以了，但是如果已经形成了两个独立的组，那么后两个组的合并可以隔离以前链接的成员 - 它们的classID没有得到新的父级更新所以他们是有效的孤儿。

Answer 2

假设：

第一列始终包含开始链接
第二列始终包含链接
要继续链接链，必须稍后在第一列中找到第二列中列出的内容以继续链（如示例所示）。这可以防止＆＃34;链接分裂＆＃34;链接可以分成不同的链。

如果这些假设成立，则此代码适用于您：

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

链接两列的条目

2 个答案: