Problem----

[Sopranos]

I have numbers in 7 columns (A-G) and 499 rows (1-499).
-Question 1: How could I see if exist two or more same rows?For example:


A B C D E
F G
3 4 19 21 25 32 38
2 3 20 22 24 25 38
6 12 13 23 28 38 39
3 6 7 17 32 37 38
5 14 23 27 29 31 37
3 4 19 21 25 32 38
5 6 11 20 22 24 34
2 5 18 22 23 25 37
2 7 13 18 25 31 32
5 13 17 28 32 36 39


How can I get how manny combinations of 3 4 19 21 25 32 38

is there in whole table?


-Question 2: How could I see how manny combinations with 5 same numbers and
two diferent there is? For example:

A B C D E
F G
3 4 19 21 25 32 38
2 3 20 22 24 25 38
6 12 13 23 28 38 39
3 6 7 17 32 37 38
5 14 23 27 29 31 37
3 4 19 21 24 27 38
5 6 11 20 22 24 34
2 5 18 22 23 25 37
2 7 13 18 25 31 32
5 13 17 28 32 36 39


How can i see that there is 2 combinations where exist 5 same numbers and 2
diferrent?

3 4 19 21 25 32 38


3 4 19 21 24 27 38



Sorry for my english... I hope that you understand me... Thanks!

 

[Ben]

You have asked some difficult questions.

I have found a solution to the first question using Aaron Bloods Find
Function (see xl-logic.com) and a bit of VBA. I am assuming the block
of numbers are starting at A1 with no headers, though you can easily
change it. I am also assuing that the block of numbers is in Sheet1.

I quite like the way the cells flicker in differnt colors. The matching
rows en up with highest row number of the set of matches in a col to
the right of the block. You can sort the block by the new col
(descending) to see all the matches. Please note that you need to
delete these before re-running.

You need to put this first bit of code in a seperate module. I provide
it, but as I mentioned it was written by Aaron.


'This should work fine in XL2002 and later.
'You may have to tweak it a bit to work with earlier versions.
'For instance, I'm told SearchFormat is not an option for the
'FIND method in XL2000 and earlier. You can wipe that line if needed.
Enum eLookin
xlFormulas = -4123
xlComments = -4144
xlValues = -4163
End Enum

Enum eLookat
xlPart = 2
xlWhole = 1
End Enum

Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As eLookin, _
Optional LookAt As eLookat, _
Optional MatchCase As Boolean) As Range

Dim c As Range, FirstAddress As String
If LookIn = 0 Then LookIn = xlValues
If LookAt = 0 Then LookAt = xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False) 'Delete this term for XL2000 and earlier
If Not c Is Nothing Then
Set Find_Range = c
FirstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

End Function

**********************Then put this bit of VBA in a seperate
module.*******************************

Sub FindInt()

Dim Ref As Range
Set Ref = Range("a1")
Dim Depth, Width, x, y, a, b, MatchedCounter As Integer
Dim RowOneColor As Boolean

'select the sheet
Sheets("Sheet2").Select

'clear the colours
Cells.Interior.ColorIndex = xlColorIndexNone

'find the depth
While Ref.Offset(Depth, 0) <> ""
Depth = Depth + 1
Wend
Depth = Depth - 1

'find the width
While Ref.Offset(0, Width) <> ""
Width = Width + 1
Wend
Width = Width - 1

For x = 0 To Depth
'make all matching rows yellow
For y = 0 To Width
Find_Range(Ref.Offset(x, y).Value, Ref.Offset(0,
y).Resize(Depth + 1, 1), xlFormulas, xlWhole).Interior.ColorIndex = 6
Next y

'count the number of matched rows
MatchedCounter = 0
For a = 0 To Depth
RowOneColor = True
For b = 0 To Width
If Ref.Offset(a, b).Interior.ColorIndex <> 6 Then
RowOneColor = False
Else
End If
Next b
If RowOneColor = True Then
MatchedCounter = MatchedCounter + 1
Else
RowOneColor = True
End If
Next a

'if more than 1 row matches then add detail
If MatchedCounter > 1 Then
For a = 0 To Depth
RowOneColor = True
For b = 0 To Width
If Ref.Offset(a, b).Interior.ColorIndex <> 6 Then
RowOneColor = False
Else
End If
Next b
If RowOneColor = True Then
Ref.Offset(a, Width + 1).Value = x + 1
Else
RowOneColor = True
End If
Next a
Else
End If
'reset interior colour to none
Cells.Interior.ColorIndex = xlColorIndexNone

Next x

Ref.Select
End Sub

 

[Ben]

Revised answer actually tackles both questions. My first attempt was
wrong. You still need Aaron's bit in a seperate module.

Sub Find5Int()

Dim Ref As Range
Set Ref = Range("a1")
Dim Depth, Width, x, y, a, b, MatchedCounter, CellCounter As
Integer
Dim RowOneColor As Boolean
Application.ScreenUpdating = False
'select the sheet
Sheets("Sheet2").Select

'clear the colours
Cells.Interior.ColorIndex = xlColorIndexNone

'find the depth
While Ref.Offset(Depth, 0) <> ""
Depth = Depth + 1
Wend
Depth = Depth - 1

'find the width
While Ref.Offset(0, Width) <> ""
Width = Width + 1
Wend
Width = Width - 1

For x = 0 To Depth
'make all matching cells yellow. Rows are completely Yellow
For y = 0 To Width
Find_Range(Ref.Offset(x, y).Value, Ref.Offset(0,
0).Resize(Depth + 1, Width + 1), xlFormulas,
xlWhole).Interior.ColorIndex = 6
Next y

'go through and count the number of matches in each row. Put
the result in Col J
For a = 0 To Depth
CellCounter = 0
For b = 0 To Width
If Ref.Offset(a, b).Interior.ColorIndex = 6 Then
CellCounter = CellCounter + 1
Else
End If
Next b
If CellCounter > 4 Then
Ref.Offset(a, Width + 3).Value = 1
Else
End If
Next a
'go through and counter the number of partially matched rows
MatchedCounter = 0
For a = 0 To Depth
MatchedCounter = MatchedCounter + Ref.Offset(a, Width +
3).Value
Next a

'place the row number of the partially matched rows in Col I
If MatchedCounter > 1 Then
For a = 0 To Depth
If Ref.Offset(a, Width + 3).Value = 1 Then
Ref.Offset(a, Width + 2).Value = x + 1
Else
End If
Next a
Else
End If

'clear the J col
Range("J:J").Value = ""

'count the number of matched rows
MatchedCounter = 0
For a = 0 To Depth
RowOneColor = True
For b = 0 To Width
If Ref.Offset(a, b).Interior.ColorIndex <> 6 Then
RowOneColor = False
Else
End If
Next b
If RowOneColor = True Then
MatchedCounter = MatchedCounter + 1
Else
RowOneColor = True
End If
Next a

'if more than 1 row matches then add detail
If MatchedCounter > 1 Then
For a = 0 To Depth
RowOneColor = True
For b = 0 To Width
If Ref.Offset(a, b).Interior.ColorIndex <> 6 Then
RowOneColor = False
Else
End If
Next b
If RowOneColor = True Then
Ref.Offset(a, Width + 1).Value = x + 1
Else
RowOneColor = True
End If
Next a
Else
End If
'reset interior colour to none
Cells.Interior.ColorIndex = xlColorIndexNone

Next x
'clear the J col
Range("J:J").Value = ""
Ref.Select
Application.ScreenUpdating = True

End Sub