Calc how to find multiple cells that repeat

[US35]

Ok so I have a random list of words, (each word takes up a cell) inside columns A-P and rows 1-100,
the words do repeat.

So my job is to find any three words (lets call any three words that do repeat a set, set can be in any order) that repeat in at least 3 rows.

And I want a chart listing each set repeated, next to each set how many rows found with that set.

I would also like to highlight each set in different colors.

[LeroyG]

So one set can be in one, two or three rows? Click edit below your question to add more information.

[JohnSUN]

Well, here is half of the solution to your problem as you described it:

Sub findAndColor
Dim aSets
	aSets = findMultipleCellsThatRepeat("Demo", "A1:P100")
Rem Now the aSets array contains information about all found sets. You can print, draw charts and more
End Sub

Function findMultipleCellsThatRepeat(sSheetName As String, sRangeName As String) As Variant 
Rem The function will collect data about duplicate values ​​and paint them on the sheet
Const MIN_COUNT = 3
Dim oSheet As Variant
Dim oRange As Variant
Dim oData As Variant
Dim i As Long, j As Long
Dim aRes As Variant 
Rem Get data from range to array:
	oSheet = ThisComponent.getSheets().getByName(sSheetName)
	oRange = oSheet.getCellRangeByName(sRangeName)
	oData = oRange.getDataArray()
Rem Count repetitions by columns:
	For i = LBound(oData(0)) To UBound(oData(0))
		oData(0)(i)= Array(oData(0)(i), 1)
		For j = LBound(oData)+1 To UBound(oData)
			If oData(j)(i) = oData(j-1)(i)(0) Then 
				oData(j)(i) = Array(oData(j)(i), oData(j-1)(i)(1) + 1)
			Else 
				oData(j)(i) = Array(oData(j)(i), 1)
			EndIf 
		Next j
	Next i
Rem Collect all sets with at least MIN_COUNT (= 3) items
	aRes = Array()
	For i = LBound(oData(0)) To UBound(oData(0))
		j = UBound(oData)
		While j > LBound(oData)
			If oData(j)(i)(1) >= MIN_COUNT Then 
				Call AppendToArray(aRes, Array(oData(j)(i)(0), oData(j)(i)(1), i, j-oData(j)(i)(1)+1, j))
				j = j-oData(j)(i)(1)
			Else 
				j = j-1
			EndIf 
		Wend 
	Next i
Rem Paint the sets randomly:	
	For i = LBound(aRes) To UBound(aRes)
		oRange.getCellRangeByPosition(aRes(i)(2), aRes(i)(3), aRes(i)(2), aRes(i)(4)).CellStyle = _
				crtStylesIfNeed(RandomColorCode(), aRes(i)(0) & "_" & aRes(i)(1)  & "_" )
	Next i
Rem Return the list of sets for further processing (including creating a diagram)
	findMultipleCellsThatRepeat = aRes
End Function

Sub AppendToArray(oData As Variant, ByVal x As Variant)
Rem Utility procedure - adds an element to the end of an existing array
Dim iLB As Long, iUB As Long
    iLB = LBound(oData, 1)
    iUB = UBound(oData, 1) + 1
    ReDim Preserve oData(iLB To iUB)
    oData(iUB) = x
End Sub

Function RandomColorCode()
Const HEX_LETTER = "0123456789ABCDEF"
	RandomColorCode = "#" & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) & _
			Mid(HEX_LETTER, Int((16 * Rnd) +1),1) 
End Function

The crtStylesIfNeed function code is there