Excel-识别唯一的值模式，并按降序返回各列的输出，针对500,000+行进行了优化

Question

这是我从事一年多的大规模数据清理任务的第三个也是最后一个问题。 感谢Stack Overflow社区帮助我们弄清楚了：

问题1-为多列建立索引并匹配不同的值...。
问题2- 计算与ID匹配的唯一值，针对100,000多个案例进行了优化。

我不确定100％是否可以在excel中实现，但是我将尽最大的努力来描述我面临的数据清理和组织挑战。

我有一系列数据标记/属性，它们随机分布在24列中，跨越500,000+行。 下图1是原始格式的数据示例，为说明简单起见，该数据跨12列显示，跨22行。 A到L列包含原始数据，M到X列代表所需的输出。

任务摘要 ：需要完成的是一系列匹配函数，这些函数搜索所有索引列（在这种情况下为A至L列）以标识唯一值（例如1），在范围内搜索值（在这种情况下） A2：L21范围），将相邻的值标识为唯一值（对于值1，相邻的值是2和13-XR），然后按从高频率出现到低频率的降序输出（包含任何有问题的值（在这种情况下，发生1次5次，放置在M2至M6中；发生2次3次，放置在N2至N6中；以及13-XR发生2次，并且放置在O2至O6中）。

为了明确起见，下面是使用颜色的逐步说明，以说明原始数据（A至L列）中的模式匹配以及这些模式应如何在输出中显示（M至X列）。 我将以下每个图像分为原始数据中的六个模式。

上图是VBA解决方案将识别的第一个图案。 它将标识“ 1”为唯一值，并在A：L范围内搜索“ 1”的实例数（以蓝色突出显示），然后标识在同一行中相邻的所有值：“ 2”在第3、5和6行中（以绿色突出显示）； 和第4和5行中的“ 13-XR”（以粉色突出显示）。 然后，对于“ 2”，需要标识相邻的值（“ 1”和“ 13-XR”），然后对于“ 13-XR”，需要标识（“ 1”和“ 2”作为相邻值）。 输出将返回唯一值，其唯一值在M列中出现频率最高（“ 1”发生5次），然后在N列中发生第二高频率（“ 2”发生3次），而在O列中出现第三高的唯一值（ “ 13-XR”出现2次）。

上面有点复杂。 VBA会将“ 3”标识为唯一值，在A：L范围内搜索“ 3”的其他实例，并标识与其相邻的所有值（在本例中为“ 4”，“ 7”和“ 9”）。 然后它将对“ 4”执行相同的操作，从而标识所有相邻值（仅“ 3”）； 然后对于“ 7”，标识相邻的值（“ 9”，“ 3”和“ 12”）； 然后用于“ 9”标识（“ 7”和“ 3”）； 最后，对于“ 12”标识相邻值（仅“ 7”）。 然后，对于存在这些值中任何一个的每一行，输出将在M列中返回“ 3”（发生3次），在N列中返回“ 7”（也发生3次）； 如果计数相等，则它们可以以升序方式从A到Z或从最小到最大...或只是随机出现，就我而言，相等计数的顺序是任意的。 O列两次将返回“ 9”，然后在P列中返回“ 4”，在Q列中返回“ 12”，因为它们都出现一次，但12大于4。

上图表示只有一个唯一值的情况可能是常见情况。 此处，该范围内的任何其他列均未标识为“ 5”。 因此，对于存在“ 5”的每一行，它在列M中以“ 5”的形式返回。

这将是另一种更常见的情况，其中一个值可能出现在一行中，而两个值出现在另一行中。 在这种情况下，“ 6”在该范围内仅被识别一次，“ 8”是唯一发现的相邻值。 搜索“ 8”时，仅返回相邻值“ 6”的一个实例。 在此，“ 8”出现两次，而“ 6”仅出现一次，因此无论行中存在“ 8”还是“ 6”，都会在列M中插入“ 8”，在列N中插入“ 6”。

在此，“ 10”，“ 111”，“ 112”，“ 543”，“ 433”，“ 444”和“ 42-FG”被标识为在A：L范围内彼此相关联的唯一值。 除“ 10”外，所有值均出现两次，并按降序返回M到S列。

以与上述相同的方式标识此最终模式，只是具有更多唯一值（n = 10）。

最后说明：我不知道如何在excel中完成此操作，但我希望其他人有知识将这一问题向前推进。 以下是有关数据的一些其他注释，这些注释可能有助于解决问题：

第一列将始终按升序排序。 如果可以简化事情，我可以进行其他自定义排序。
在约500,000行中，只有15％具有一个属性值（A列中的一个值），30％具有两个属性值（col A中的一个值和col B中的1值），13％具有三个属性值（1 A，B和C中的值）。
在此示例中，我给出了一些数字。 每个单元格中的实际原始数据值的长度将接近20个字符。
除了按降序显示模式外，什么都不做的解决方案绝对是很酷的。 排序会很棒，但是如果它引起太多麻烦，我可以不用它。

如果本说明中的任何内容需要进一步说明，或者我可以提供其他信息，请告知我，我们会根据需要进行调整。

在此先感谢任何可以帮助解决我的最终挑战的人。

附录：

完整的数据集发生内存错误。 @ambie发现错误的根源是相邻链（结果）在1000年代的编号（试图返回1000列的结果）。 似乎问题不在于解决方案或数据，而只是在excel中遇到限制。 一个可能的解决方案是（请参见下图）添加两个新列（ATT_COUNT作为列M； ATT_ALL作为列Z）。 列M中的ATT_COUNT将返回通常跨列返回的唯一值的总数。 在N到Y列（ATT_1_CL到ATT_12_CL）中，最多只会返回最常见的前12个值。 要绕开ATT_COUNT> 12（大于1000+）的实例，我们可以用ATT_ALL（Z列）以空格分隔的格式返回所有唯一值。 例如，在下图中，行17、18、19和21在链中具有17个唯一值。 在N到Y列中仅显示前12个最频繁出现的值。在Z列中以空格分隔的格式显示所有17个值。

这是此迷你示例测试数据的链接。

这是一个约5万行中型测试数据样本的链接。

这是约50万行的完整样本测试数据的链接。

Answer 1

通常，我们不提供“为您提供服务的代码”，但是我知道在前面的问题中，您已经提供了一些尝试过的示例代码，而且我可以看到您不知道从哪里开始。

对于您将来的编码工作，诀窍是将问题分解为单独的任务。 对于您的问题，这些将是：

识别所有唯一值并获取所有相邻值的列表-非常简单。
创建一个将一个相邻值链接到下一个值的“链”列表-这样做比较尴尬，因为尽管列表看起来是排序的，但相邻值却没有，因此列表中相对较低的值可能与较高的值相邻这已经是一条链的一部分了（样本中的3是一个例子）。 因此，最简单的方法是仅在读取所有唯一值之后才分配链。
将每个唯一值映射到其适当的“链”-我通过为链创建索引并将相关的一个值分配给唯一值来完成此操作。

Collection对象是您的理想选择，因为它们处理重复项，允许您填充未知大小的列表，并使用其Key属性使值映射变得容易。 为了使编码易于阅读，我创建了一个包含一些字段的类。 因此，首先，插入一个Class Module并将其命名为cItem 。 该类背后的代码是：

Option Explicit

Public Element As String
Public Frq As Long
Public AdjIndex As Long
Public Adjs As Collection

Private Sub Class_Initialize()
    Set Adjs = New Collection
End Sub

在您的模块中，可以将任务编码如下：

Dim data As Variant, adj As Variant
Dim uniques As Collection, chains As Collection, chain As Collection
Dim oItem As cItem, oAdj As cItem
Dim r As Long, c As Long, n As Long, i As Long, maxChain As Long
Dim output() As Variant

'Read the data.
'Note: Define range as you need.
With Sheet1
    data = .Range(.Cells(2, "A"), _
                  .Cells(.Rows.Count, "A").End(xlUp)) _
           .Resize(, 12) _
           .Value2
End With

'Find the unique values
Set uniques = New Collection
For r = 1 To UBound(data, 1)
    For c = 1 To UBound(data, 2)
        If IsEmpty(data(r, c)) Then Exit For
        Set oItem = Nothing: On Error Resume Next
        Set oItem = uniques(CStr(data(r, c))): On Error GoTo 0
        If oItem Is Nothing Then
            Set oItem = New cItem
            oItem.Element = CStr(data(r, c))
            uniques.Add oItem, oItem.Element
        End If
        oItem.Frq = oItem.Frq + 1
        'Find the left adjacent value
        If c > 1 Then
            On Error Resume Next
            oItem.Adjs.Add uniques(CStr(data(r, c - 1))), CStr(data(r, c - 1))
            On Error GoTo 0
        End If
        'Find the right adjacent value
        If c < UBound(data, 2) Then
            If Not IsEmpty(data(r, c + 1)) Then
                On Error Resume Next
                oItem.Adjs.Add uniques(CStr(data(r, c + 1))), CStr(data(r, c + 1))
                On Error GoTo 0
            End If
        End If
    Next
Next

'Define the adjacent indexes.
For Each oItem In uniques
    'If the item has a chain index, pass it to the adjacents.
    If oItem.AdjIndex <> 0 Then
        For Each oAdj In oItem.Adjs
            oAdj.AdjIndex = oItem.AdjIndex
        Next
    Else
        'If an adjacent has a chain index, pass it to the item.
        i = 0
        For Each oAdj In oItem.Adjs
            If oAdj.AdjIndex <> 0 Then
                i = oAdj.AdjIndex
                Exit For
            End If
        Next
        If i <> 0 Then
            oItem.AdjIndex = i
            For Each oAdj In oItem.Adjs
                oAdj.AdjIndex = i
            Next
        End If
        'If we're still missing a chain index, create a new one.
        If oItem.AdjIndex = 0 Then
            n = n + 1
            oItem.AdjIndex = n
            For Each oAdj In oItem.Adjs
                oAdj.AdjIndex = n
            Next
        End If
    End If
Next

'Populate the chain lists.
Set chains = New Collection
For Each oItem In uniques
    Set chain = Nothing: On Error Resume Next
    Set chain = chains(CStr(oItem.AdjIndex)): On Error GoTo 0
    If chain Is Nothing Then
        'It's a new chain so create a new collection.
        Set chain = New Collection
        chain.Add oItem.Element, CStr(oItem.Element)
        chains.Add chain, CStr(oItem.AdjIndex)
    Else
        'It's an existing chain, so find the frequency position (highest first).
        Set oAdj = uniques(chain(chain.Count))
        If oItem.Frq <= oAdj.Frq Then
            chain.Add oItem.Element, CStr(oItem.Element)
        Else
            For Each adj In chain
                Set oAdj = uniques(adj)
                If oItem.Frq > oAdj.Frq Then
                    chain.Add Item:=oItem.Element, Key:=CStr(oItem.Element), Before:=adj
                    Exit For
                End If
            Next
        End If
    End If
    'Get the column count of output array
    If chain.Count > maxChain Then maxChain = chain.Count
Next

'Populate each row with the relevant chain
ReDim output(1 To UBound(data, 1), 1 To maxChain)
For r = 1 To UBound(data, 1)
    Set oItem = uniques(CStr(data(r, 1)))
    Set chain = chains(CStr(oItem.AdjIndex))
    c = 1
    For Each adj In chain
        output(r, c) = adj
        c = c + 1
    Next
Next

'Write the output to sheet.
'Note: adjust range to suit.
Sheet1.Range("M2").Resize(UBound(output, 1), UBound(output, 2)).Value = output

这不是最有效的方法，但是它确实使每个任务对您而言都更加明显。 我不确定我是否理解您的数据结构的全部复杂性，但是上面的代码确实重现了您的示例，因此它应该为您提供一些有用的东西。

更新资料

好的，现在我已经看到了您的评论和真实数据，下面是一些经过修改的代码，这些代码应该更快，并且可以处理以下事实：表面上“空”的单元格实际上是空字符串。

首先创建一个名为cItem的类，并在其后添加代码：

Option Explicit

Public Name As String
Public Frq As Long
Public Adj As Collection
Private mChainIndex As Long
Public Property Get ChainIndex() As Long
    ChainIndex = mChainIndex
End Property
Public Property Let ChainIndex(val As Long)
    Dim oItem As cItem
    If mChainIndex = 0 Then
        mChainIndex = val
        For Each oItem In Me.Adj
            oItem.ChainIndex = val
        Next
    End If            
End Property
Public Sub AddAdj(oAdj As cItem)
    Dim t As cItem

    On Error Resume Next
    Set t = Me.Adj(oAdj.Name)
    On Error GoTo 0
    If t Is Nothing Then Me.Adj.Add oAdj, oAdj.Name
End Sub
Private Sub Class_Initialize()
    Set Adj = New Collection
End Sub

现在创建另一个名为cChain的类，其代码为：

Option Explicit

Public Index As Long
Public Members As Collection
Public Sub AddItem(oItem As cItem)
    Dim oChainItem As cItem
    With Me.Members
        Select Case .Count
            Case 0 'First item so just add it.
                .Add oItem, oItem.Name
            Case Is < 12 'Fewer than 12 items, so add to end or in order.
                Set oChainItem = .item(.Count)
                If oItem.Frq <= oChainItem.Frq Then 'It's last in order so just add it.
                    .Add oItem, oItem.Name
                Else 'Find its place in order.
                    For Each oChainItem In Me.Members
                        If oItem.Frq > oChainItem.Frq Then
                            .Add oItem, oItem.Name, before:=oChainItem.Name
                            Exit For
                        End If
                    Next
                End If
            Case 12 'Full list, so find place and remove last item.
                Set oChainItem = .item(12)
                If oItem.Frq > oChainItem.Frq Then
                    For Each oChainItem In Me.Members
                        If oItem.Frq > oChainItem.Frq Then
                            .Add oItem, oItem.Name, before:=oChainItem.Name
                            .Remove 13
                            Exit For
                        End If
                    Next
                End If
        End Select
    End With
End Sub
Private Sub Class_Initialize()
    Set Members = New Collection
End Sub

最后，您的模块代码为：

Option Explicit

Public Sub ProcessSheet()
    Dim data As Variant
    Dim items As Collection, chains As Collection
    Dim oItem As cItem, oAdj As cItem
    Dim oChain As cChain
    Dim txt As String
    Dim r As Long, c As Long, n As Long
    Dim output() As Variant
    Dim pTick As Long, pCount As Long, pTot As Long, pTask As String

    'Read the data.
    pTask = "Reading data..."
    Application.StatusBar = pTask
    With Sheet1
        data = .Range(.Cells(2, "A"), _
                      .Cells(.Rows.Count, "A").End(xlUp)) _
               .Resize(, 12) _
               .Value2
    End With

    'Collect unique and adjacent values.
    pTask = "Finding uniques "
    pCount = 0: pTot = UBound(data, 1): pTick = 0
    Set items = New Collection
    For r = 1 To UBound(data, 1)
        If ProgressTicked(pTot, pCount, pTick) Then
            Application.StatusBar = pTask & pTick & "%"
            DoEvents
        End If
        For c = 1 To UBound(data, 2)
            txt = data(r, c)
            If Len(txt) = 0 Then Exit For
            Set oItem = GetOrCreateItem(items, txt)
            oItem.Frq = oItem.Frq + 1

            'Take adjacent on left.
            If c > 1 Then
                txt = data(r, c - 1)
                If Len(txt) > 0 Then
                    Set oAdj = GetOrCreateItem(items, txt)
                    oItem.AddAdj oAdj
                End If
            End If
            'Take adjacent on right.
            If c < UBound(data, 2) Then
                txt = data(r, c + 1)
                If Len(txt) > 0 Then
                    Set oAdj = GetOrCreateItem(items, txt)
                    oItem.AddAdj oAdj
                End If
            End If

        Next
    Next

    'Now that we have all the items and their frequencies,
    'we can find the adjacent chain indexes by a recursive
    'call of the ChainIndex set property.
    pTask = "Find chain indexes "
    pCount = 0: pTot = items.Count: pTick = 0
    Set chains = New Collection
    n = 1 'Chain index.
    For Each oItem In items
        If ProgressTicked(pTot, pCount, pTick) Then
            Application.StatusBar = pTask & pTick & "%"
            DoEvents
        End If
        If oItem.ChainIndex = 0 Then
            oItem.ChainIndex = n
            Set oChain = New cChain
            oChain.Index = n
            chains.Add oChain, CStr(n)
            n = n + 1
        End If
    Next

    'Build the chains.
    pTask = "Build chains "
    pCount = 0: pTot = items.Count: pTick = 0
    For Each oItem In items
        If ProgressTicked(pTot, pCount, pTick) Then
            Application.StatusBar = pTask & pTick & "%"
            DoEvents
        End If
        Set oChain = chains(CStr(oItem.ChainIndex))
        oChain.AddItem oItem
    Next

    'Write the data to our output array.
    pTask = "Populate output "
    pCount = 0: pTot = UBound(data, 1): pTick = 0
    ReDim output(1 To UBound(data, 1), 1 To 12)
    For r = 1 To UBound(data, 1)
        If ProgressTicked(pTot, pCount, pTick) Then
            Application.StatusBar = pTask & pTick & "%"
            DoEvents
        End If
        Set oItem = items(data(r, 1))
        Set oChain = chains(CStr(oItem.ChainIndex))
        c = 1
        For Each oItem In oChain.Members
            output(r, c) = oItem.Name
            c = c + 1
        Next
    Next

    'Write the output to sheet.
    'Note: adjust range to suit.
    pTask = "Writing data..."
    Application.StatusBar = pTask
    Sheet1.Range("M2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
    Application.StatusBar = "Ready"
End Sub

Private Function GetOrCreateItem(col As Collection, key As String) As cItem
    Dim obj As cItem

    'If the item already exists then return it,
    'otherwise create a new item.
    On Error Resume Next
    Set obj = col(key)
    On Error GoTo 0

    If obj Is Nothing Then
        Set obj = New cItem
        obj.Name = key
        col.Add obj, key
    End If

    Set GetOrCreateItem = obj

End Function
Public Function ProgressTicked(ByVal t As Long, ByRef c As Long, ByRef p As Long) As Boolean
    c = c + 1
    If Int((c / t) * 100) > p Then
        p = p + 1
        ProgressTicked = True
    End If
End Function

Excel-识别唯一的值模式，并按降序返回各列的输出，针对500,000+行进行了优化

问题描述

1 个解决方案

解决方案1
2 已采纳 2017-07-13 15:45:46

Excel-识别唯一的值模式，并按降序返回各列的输出，针对500,000+行进行了优化

问题描述

1 个解决方案

解决方案1 2 已采纳 2017-07-13 15:45:46

解决方案1
2 已采纳 2017-07-13 15:45:46