查找以特定顺序重复的行，并按重复次数显示结果

我能够使用Python解决这个问题，但是我需要在Excel本身中实现解决scheme，以便我可以使用graphics轻松地表示结果。

鉴于此表：

bac cabacb ac acd bca dca 

我想获得一个列表，按行中重复的次数（没有特定的顺序）sorting。

• 所以这将被视为重复的行：“abc”，“cba”，“acb”
• 但是这不会：“abc”，“bc”，“b”，“ab”，“ac”

所以，我正在寻找的输出将是这样的：

 1st place: "b+a+c" found 4 times 2nd place: "a+c+d" found 2 twice 3rd place: "a+c" found once 

即使输出“a + b + c”，“c + b + a”等等，输出也必须说“b + a + c”，因为“b + a + c”是第一个其他所有重复之一。

任何人都可以告诉我解决问题的正确方法吗？

Answer 1

我会使用一个类模块和一个集合对象。 类模块将由两个数组和一个计数器组成。 第一个数组是按照原始顺序的行; 第二个数组是按sorting顺序的行。 sorting的顺序将被用作集合对象的键。 如果您尝试添encryption钥已存在的集合对象，则会导致错误。 捕获错误并将其添加到计数器。

然后，对于结果，您将检索“原始”数组中的原始条目; 和柜台。 sorting在柜台上，你有你的结果。

这是一个VBA代码来完成上述的一个例子。

首先，插入一个Class模块并将其重命名为RowEntries

 Option Explicit Private pOriginal() As Variant Private pSorted() As Variant Private pCount As Long Public Property Get Original() As Variant Original = pOriginal End Property Public Property Let Original(Value As Variant) pOriginal = Value End Property Public Property Get Sorted() As Variant Sorted = pSorted End Property Public Property Let Sorted(Value As Variant) pSorted = Value End Property Public Property Get Count() As Long Count = pCount End Property Public Property Let Count(Value As Long) pCount = Value End Property 

然后插入一个常规模块。 这段代码假设你的源数据是A1的CurrentRegion; 结果会在右边几列。 这些algorithm很容易改变。

 Option Explicit Option Compare Text 'To make comparison case insensitive, if you want Sub RankRows() Dim V As Variant, VtoSort As Variant Dim vRes() As Variant Dim cRowEntries As RowEntries Dim colRowEntries As Collection Dim sKey As String, S As String Dim I As Long Dim rSrc As Range, rRes As Range 'Location for Results Set rSrc = Range("A1").CurrentRegion Set rRes = rSrc.Offset(columnoffset:=rSrc.Columns.Count + 3).Resize(1, 2) V = rSrc Set colRowEntries = New Collection On Error Resume Next For I = 1 To UBound(V) Set cRowEntries = New RowEntries With cRowEntries .Original = WorksheetFunction.Index(V, I, 0) VtoSort = .Original Quick_Sort VtoSort, LBound(VtoSort), UBound(VtoSort) .Sorted = VtoSort .Count = 1 sKey = CStr(Join(.Sorted, ", ")) colRowEntries.Add cRowEntries, sKey If Err.Number <> 0 Then Err.Clear With colRowEntries(sKey) .Count = .Count + 1 End With End If End With Next I On Error GoTo 0 'populate results array ReDim vRes(1 To colRowEntries.Count, 1 To 2) For I = 1 To colRowEntries.Count With colRowEntries(I) vRes(I, 1) = Join(.Original, "+") 'remove trailing delimiters Do While Right(vRes(I, 1), 1) = "+" vRes(I, 1) = Left(vRes(I, 1), Len(vRes(I, 1)) - 1) Loop vRes(I, 2) = .Count End With Next I Set rRes = rRes.Resize(rowsize:=UBound(vRes), columnsize:=UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes .Sort key1:=rRes.Columns(2), order1:=xlDescending, Header:=xlNo End With V = rRes ReDim vRes(1 To UBound(V), 1 To 1) For I = 1 To UBound(V) Select Case V(I, 2) Case 1 S = "once" Case 2 S = "twice" Case Else S = V(I, 2) & " times" End Select vRes(I, 1) = OrdinalNum(I) & " place: """ & V(I, 1) & """ found " & S Next I rRes.EntireColumn.Clear rRes.Resize(columnsize:=1) = vRes rRes.EntireColumn.AutoFit End Sub Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long) Dim Low As Long, High As Long Dim Temp As Variant, List_Separator As Variant Low = first High = last List_Separator = SortArray((first + last) / 2) Do Do While (SortArray(Low) < List_Separator) Low = Low + 1 Loop Do While (SortArray(High) > List_Separator) High = High - 1 Loop If (Low <= High) Then Temp = SortArray(Low) SortArray(Low) = SortArray(High) SortArray(High) = Temp Low = Low + 1 High = High - 1 End If Loop While (Low <= High) If (first < High) Then Quick_Sort SortArray, first, High If (Low < last) Then Quick_Sort SortArray, Low, last End Sub Function OrdinalNum(num) As String Dim Suffix As String OrdinalNum = num If Not IsNumeric(num) Then Exit Function If num <> Int(num) Then Exit Function Select Case num Mod 10 Case Is = 1 Suffix = "st" Case Is = 2 Suffix = "nd" Case Is = 3 Suffix = "rd" Case Else Suffix = "th" End Select Select Case num Mod 100 Case 11 To 19 Suffix = "th" End Select OrdinalNum = Format(num, "#,##0") & Suffix End Function 

输出将如您在上面的请求中显示的一样。 但可以很容易地修改：

Answer 2

我build议你另外解决这个问题。

您可以传送abcd到1 2 4 8（二进制是01 10 100 1000）。

 a+b+c = a+c+b =... = 7 (111) a+c = c+a = 5 (101) 

所以你可以使用总和值在Excel中分组。

将单个字符转换为数字的function非常简单：

 ABC POWER(2,CODE(A2) - 97) POWER(2,CODE(A2) - 97) POWER(2,CODE(A2) - 97) SUM(D2:F2) -+-+-+-----------------------+-----------------------+-----------------------+---------- b|a|c|2 |1 |4 |7 c|a|b|4 |1 |2 |7 a|c|b|1 |4 |2 |7 a|c| |1 |4 |0 |5 a|c|d|1 |4 |8 |13 b|c|a|2 |4 |1 |7 d|c|a|8 |4 |1 |13 

希望这种方法可以帮助你find自己的方式来解决你的问题。

Answer 3

这个问题太有意思了。 这是展示如何使用math来提供更简单的解决scheme的一个很好的例子。

我不得不增加另一个答案，因为我意识到find三个词的重复组合是相同的从三个空间计算距离从零点 – 只需要给每个单词一个不同的数字。 这个答案可以解决Pnuts之前提到的问题。

与我上次的回答不同的是，如果你在三位成员中有200个短语和组合，计算的最大数字是120000（POWER（200,2）* 3），我的最后一个答案是1.60694E + 60（POWER（2,200））。 我最后的回答可能逻辑上解决了这个问题，但不能用Excel或许多编程语言来实现。 它使用排列解决scheme来解决组合问题。

这里是三空间距离的解决scheme，简单易用。

1. 将每个单词映射到不同的编号。 （VLOOKUP是一种方法，您可能有其他方法）。结果数字不需要是连续的，只是彼此不同，最大数量应小于SQRT（POWER（2,32）/ 3））。 。
2. 使用G1中的公式计算距离。
3. 分组和计数使用列G.（有些方法可以在其他答案中find）
4. 注意：我用'_'取代了空格单元，为空间映射一个数字，所以可以使a_a等于aa_（第4行和第5行）。 任何select都应该有一个空格的数字。

任何意见，以改善这个答案，将不胜感激。

Answer 4

几乎只有公式解决scheme，假设数据在D2中标记为ColumnsA：C：

 =VLOOKUP(A2,weight,2,0)+IFNA(VLOOKUP(B2,weight,2,0),)+IFNA(VLOOKUP(C2,weight,2,0),) 

复制下来以适应，其中weight （图像中的绿色）是查找表的命名范围（沿着@Jaugar Chang所build议的线构build）。 在E2中复制下来以适应：

  =IF(COUNTIF(D$2:D2,D2)=1,COUNTIF(D:D,D2),"") 

在G1：

 =ROW()&MID("thstndrdthstndrdth",MATCH(IF(MOD(ROW(),100)>29,MOD(ROW(),10)+20,MOD(ROW(),100)),{0,1,2,3,4,21,22,23,24},1)*2-1,2)&" place: """&INDIRECT("A"&MATCH(H1,E:E,0))&"+"&INDIRECT("B"&MATCH(H1,E:E,0))&"+"&INDIRECT("C"&MATCH(H1,E:E,0))&""" found" 

在H1：

 =LARGE(E:E,ROW()) 

在I1：

 =IF(H1>2,"times",IF(H1=1,"","twice")) 

最后三个中的每一个都复制下来，直到出现错误消息。

ColumnH格式化：

 [=1] "once";General 

输出高亮显示黄色：

在这个例子中，有一个剩余+和剩余的可能性。

Answer 5

我会这样做的方式是使用字典来浏览列表并计算行数。 关键是行本身，所以我可以使用Dictionary.Exists(Key)方法来查看我是否已经遇到该行。 与每个键关联的值将是一个整数，每当我再次遇到同一行时，我都会增加该整数。

parsing列表后，我将遍历字典输出他们的键和值在Excel中的列。 最后，我会使用sorting的范围，我输出的结果按频率sorting。

这很容易，但是您需要引用Microsoft Scripting Runtime来使用字典对象（例如，请参阅http://www.techbookreport.com/tutorials/vba_dictionary.html ）。

希望这可以帮助。

UPDATE

既然你说过你可以试试这个方法vba。 我曾经想过，当我第一次使用Collection和Dictionary对象的时候，我会添加一些总是绊倒我的东西。 迭代条目时，迭代variables必须是Variant 。 我习惯于不得不声明与迭代的数据types相同的迭代variables，但这会给vba中的错误。

Answer 6

这里是我的版本使用数组操作，然后一些范围操纵。

编辑1：我已经阅读pnut关于处理b的评论。 顺便说一句，这不会处理+ a

 Sub Test() Dim arr, unq Dim orng As Range, rng As Range, srng As Range Dim i As Long, k As Long Dim check As Boolean: check = False Dim freq As String '~~> pass range data to array Set orng = Sheet1.Range("A1", _ Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp)) For Each rng In orng If Not IsArray(arr) Then arr = Array(RngToArr(rng.Resize(, 3))) Else ReDim Preserve arr(UBound(arr) + 1) arr(UBound(arr)) = RngToArr(rng.Resize(, 3)) End If Next '~~> pass unique combination and count to another array For i = LBound(arr) To UBound(arr) If IsEmpty(unq) Then ReDim unq(1 To 2, 1 To 1) unq(1, 1) = arr(i) unq(2, 1) = unq(2, 1) + 1 Else For k = LBound(unq, 2) To UBound(unq, 2) If CompArr(arr(i), unq(1, k)) Then check = False unq(2, k) = unq(2, k) + 1 Exit For Else check = True End If Next If check Then ReDim Preserve unq(1 To 2, 1 To UBound(unq, 2) + 1) unq(1, UBound(unq, 2)) = arr(i) unq(2, UBound(unq, 2)) = unq(2, UBound(unq, 2)) + 1 End If End If Next '~~> Transpose and tidy up the array ReDim tally(1 To UBound(unq, 2), 1 To 2) For i = LBound(unq, 2) To UBound(unq, 2) tally(i, 1) = Join$(unq(1, i), "+") tally(i, 2) = unq(2, i) Next '~~> sort in worksheet, easier than sorting array With Sheet1 Set srng = .Range("E1:F" & UBound(tally, 1)) srng = tally .Sort.SortFields.Clear .Sort.SortFields.Add Key:=srng.Offset(0, 1).Resize(, 1), _ SortOn:=xlSortOnValues, Order:=xlDescending, _ DataOption:=xlSortNormal With .Sort .SetRange srng .Header = xlGuess .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With '~~> do some manipulation to make it closer to what you want For Each rng In srng.Offset(0, 1).Resize(, 1) Select Case rng.Value Case 1: freq = "found once" Case 2: freq = "found twice" Case Else: freq = "found " & rng.Value & " times" End Select rng.Value = freq Next End Sub 

---

 Private Function CompArr(list1, list2) As Boolean Dim j As Long: CompArr = True For j = LBound(list1) To UBound(list1) With Application If IsError(.Match(list1(j), list2, 0)) _ Then CompArr = False End With Next End Function 

---

 Private Function RngToArr(r As Range) As Variant Dim c As Range, a For Each c In r If Len(c.Value) <> 0 Then If Not IsArray(a) Then a = Array(c.Value) Else ReDim Preserve a(UBound(a) + 1) a(UBound(a)) = c.Value End If End If Next RngToArr = a End Function 

结果：

不完全是你想要的方式，我无法dynamic地设置第一名，第二名等 。
另外，我没有深入加号（+）。 如果有空白，结果可能是+ b + c，或a + c +或a ++ c。
反正，HTH。