Excel – 识别唯一的值模式，并以列递减顺序返回输出，为500,000多行进行了优化
这是我一直在努力工作了一年的海量数据清理任务的第三个也是最后一个问题。 谢谢Stack Overflow社区帮忙解决：
问题1- 索引多个列并匹配不同的值…。
问题2 – 计数匹配ID的唯一值，针对100,000个以上的情况进行优化 。
我不是100％确定在excel中是否可以实现以下目标，但我将尽我所能来描述我面临的数据清理和组织挑战。
我有一系列数据标记/属性，它们是按24列随机排列的，跨越了500,000多行。 下面的图1是为了说明的简单性，以原始forms呈现的数据的示例，跨越12列呈现并跨越22行。 列A到L包含原始数据，列M到X代表所需的输出。
任务概要 ：需要完成的是一系列匹配函数，这些函数在所有索引列（在这种情况下，列A到L）中search以识别唯一值（例如1），search范围内的值（在这种情况下A2：L21范围），将唯一值的相邻值（对于值1，相邻值是2和13-XR）进行标识，然后以从最频繁出现的值到最不频繁出现的每行中的降序排列任何一个值（在这种情况下，1出现5次，通过M6放置在M2中; 2出现3次，通过N6放置在N2中; 13-XR出现2次，通过O6放置在O2中） 。
为了澄清，以下是使用颜色来逐步描述原始数据（列A到L）中的模式匹配以及如何在输出（列M到X）中呈现这些模式的步骤。 我已经将以下每个图像分成了六个原始数据模式。
上面的图片是VBA解决scheme可以识别的第一个图案。 它会将“1”识别为一个唯一的值，并通过A：L范围search“1”的实例数量（以蓝色突出显示），然后确定在同一行中可以find相邻的所有值：“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”识别为一个唯一的值，search其他“3”实例的A：L范围，并确定与其相邻的所有值（在本例中为“4”，“7”和“9”）。 然后对“4”做相同的操作，识别所有相邻的值（仅“3”）; 那么对于“7”，识别相邻的值（“9”，“3”和“12”）; 然后为“9”标识（“7”和“3”）; 最后为“12”标识相邻值（仅“7”）。 然后，对于存在任何这些值的每一行，输出将返回M列（出现三次）的“3”和N列（也出现三次）的“7”。 如果计数是相等的，它们可以从A到Z或从小到大或者随机出现，相同计数的sorting对我来说是任意的。 在列O中发生两次“9”，在列P中为“4”，在列Q中为“12”，因为它们都发生一次，但是12大于4。
上面的图像表示可能是常见的情况，只有一个唯一的值。 这里，“5”在该范围内的任何其他列中都没有标识。 因此，对于存在“5”的每行，在列M中返回为“5”。
这将是另一个更常见的事件，其中一个值可能出现在一行中，而另一个值出现在另一行中。 在这种情况下，“6”只在范围内标识一次，“8”是唯一的相邻值。 当“8”被search时，它只返回一个相邻值“6”的实例。 这里，“8”出现两次，“6”只出现一次，从而导致列M中包含“8”，并且在列中存在“8”或“6”的列中“6”包含在列中。
这里，将“10”，“111”，“112”，“543”，“433”，“444”和“42-FG”识别为在A：L范围内彼此关联的唯一值。 除“10”以外的所有值都会出现两次，这些值在M到S列中按降序排列。
这个最后的模式是以上述相同的方式确定的，只是具有更多独特的值（n = 10）。
最后的注意事项：我不知道如何在excel中完成这个任务，但是我希望别人有这个知识来推动这个问题。 以下是有关可能有助于解决问题的数据的其他说明：
- 第一列总是按升序排列。 如果它简化了事情，我可以做其他的自定义sorting。
- 在〜500,000行中，15％只有一个属性值（A列中的一个值），30％有两个属性值（col A中的1个值和col B中的1个值），13％具有三个属性值（1 A，B，C栏中的值）。
- 在这个例子中，我提出了一些小数字。 每个单元格中的实际原始数据值将接近20个字符。
- 一个解决scheme除了按降序呈现模式之外，其他的都是绝对的酷炫。 sorting会很好，但如果造成太多的麻烦，我可以没有它。
如果此描述中的任何内容需要进一步澄清，或者如果我可以提供更多信息，请告诉我，我将根据需要进行调整。
提前感谢任何人可以帮助解决我的这个最后的挑战。
附录：
整个数据集发生内存错误。 @ambie计算出错误的来源是在1000年代的相邻链（结果）编号（试图返回1000个列的结果）。 似乎问题不在于解决scheme或数据，只是在excel中碰到一个限制。 一个可能的解决scheme是（见下图）添加两个新列（ATT_COUNT作为列M; ATT_ALL作为列Z）。 列M中的ATT_COUNT将返回通常通过列返回的唯一值的总数。 只有最多12个最频繁出现的值将在N到Y列（ATT_1_CL到ATT_12_CL）中返回。 为了解决ATT_COUNT大于12（＆+ 1000以上）的情况，我们可以在ATT_ALL（Z列）中以空格分隔格式返回所有唯一值。 例如，在下图中，第17,18,19和21行在链中有17个唯一值。 在N列到Y列中只显示前12个最频繁出现的值。所有17个值以列Z中以空格分隔的格式呈现。
这里是这个小例子testing数据的链接 。
这是一个链接到大约50k行testing数据的中等大小的样本 。
这是一个链接到500k行的全尺寸的样本testing数据 。
我们通常不会提供“代码服务”，但在前面的问题中，我知道您已经提供了一些您已经尝试过的示例代码，而且我可以看到您不知道从哪里开始。
为了将来的编码工作，诀窍是将问题分解成单个任务。 对于你的问题，这些将是：
- 确定所有的唯一值并获取所有相邻值的列表 – 非常简单。
- 创build一个连接一个相邻值到下一个值的“链”列表 – 这是更为尴尬的，因为虽然列表出现sorting，但相邻的值不是，所以列表中相对较低的值可能与较高的值相邻那已经是一个链条的一部分了（你的例子中的3就是这个例子）。 所以最简单的事情就是只有在所有的唯一值被读取后才分配链。
- 将每个唯一值映射到适当的“链” – 我通过为链创build索引并将相关值分配给唯一值来完成此操作。
Collection对象非常适合您，因为它们处理重复的问题，允许您填充未知大小的列表，并使用它们的Key属性使值映射变得容易。 为了使编码易于阅读，我创build了一个包含一些字段的类。 所以首先插入一个类模块并将其称为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
这并不是最有效的方法，但它确实使每个任务对你更明显。 我不确定我是否理解了数据结构的复杂性，但是上面的代码重现了您的示例，所以它应该给您提供一些帮助。
更新
好吧，现在我已经看到了你的评论和真实的数据，下面是一些修改后的代码，应该更快，并处理这样一个事实：显然“空”单元实际上是空string。
首先创build一个名为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
现在创build另一个名为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