鏈接來自兩列的條目

Question

我有兩列中的ID，比方說列A和列B.在這些列中是ID，它們將以a或b多次出現。我想要做的是提供一個批號，如下面的例子，其中任何相關的ID被放在一個批次下。

有什麼好的想法，如何在Excel/VBA中做到這一點？我有15000行。到目前爲止，我已經嘗試循環遍歷每一行，並試圖用2標記1，然後2到4等，但for循環突然變得幾乎無限。我不在乎提供代碼，它更多的是邏輯端！

Answer 1

這是我貼在18Oct的代碼有一個嚴重的錯誤的19Oct和其他一些失敗的修改。希望這個版本更有效。我已經在這篇文章的末尾提到了一個關於bug的說明。

該解決方案利用一個類cGroup表示一個組的標識符，其中一個組被定義爲列A和列B中出現在相同行上的所有字符串。因此，組的成員意味着在工作表的某個地方有一行上有同一組的兩個成員，並且至少有一個成員也出現在列表中的另一行（除非這兩個值只出現一次，同一排，他們有一組他們自己的）。每個組都有一個原始類ID，它在創建時被分配，但它可能稍後會鏈接到另一個父組（見下文），在這種情況下，它會採用其父組的類ID。

該代碼沿着列表運行，並將列A和列B中的鍵值賦予預先存在的組，如果其中任何一個鍵先前出現在列表中。如果以前都沒有出現過，那麼爲他們創建一個具有新類ID的新組。如果他們以前出現在不同的行上並被分配到不同的組，那麼這些組必須被鏈接。這是通過選擇一個組作爲另一個的父親，然後可以形成子>父母關係的層次結構。子組採用其父級的classID - ClassID屬性包含此的邏輯。這種方法的一大優點是它避免了大規模迭代，儘管仍然會迭代child> Parent ClassID層次結構以發現hiearchy中較低級別的子類的ClassID。

我使用Scripting.Dictionary提供從一個鍵到它的類的查找。要在代碼中使用它，請在Tools> References中設置對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類

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 

---

關於錯誤：在我早期版本的代碼中，組層次結構不起作用，因爲它是將父類ID簡單分配給組。只要這些組以受控順序連接，這就沒有問題，但是如果兩個單獨的組已經形成，則後面的兩個組的合併可能會隔離先前鏈接的成員 - 它們的classID沒有更新到新的父級上課，所以他們有效的孤兒。

Answer 2

假設：

• 第一列始終包含啓動鏈接
• 第二列始終包含鏈條
• 要繼續鏈條，什麼是在第二列中列出以後必須在第一列中發現繼續鏈（如你的例子所示）。這可以防止鏈路可以分裂成不同鏈路的「鏈路分裂」。

如果這些假設是真的，那麼這段代碼會爲你工作：

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