Hi,

I hope that Juan Pablo's suggestion corrected the error you were receiving and that the routine is running, as I did not receive the error in my tests.

I have added to the code to show only the unique values. Again, please test this and report your results.

<pre>Sub test()

Dim x As Integer, y As Integer, z As Integer

Dim ws As Worksheet

Dim MyArr1

Dim MyArr2

Dim MyArr3

Dim MyArr4

Dim Rng As Range, Rng2 As Range, Rng3 As Range

Dim Counter As Long, CompareString As String

Dim fn As WorksheetFunction

Set fn = Application.WorksheetFunction

Set ws = ThisWorkbook.Sheets("Sheet1")

Set Rng = ws.Range("DM194:DO358")

ReDim MyArr2(0 To 2)

MyArr1 = Array(1, 13, 14)

With ws

For x = 13 To 130

If fn.CountA(.Cells(x, 13), .Cells(x, 14)) Then

For y = 0 To 2

MyArr2

= .Cells(x, MyArr1

)

Next y

For z = 194 To 358

If fn.CountA(.Cells(z, 117), .Cells(z, 118), .Cells(z, 119)) = 0 Then

.Range(.Cells(z, 117), .Cells(z, 119)) = MyArr2

Exit For

End If

Next z

ReDim MyArr2(0 To 2)

End If

Next x

Rng.Sort _

Key1:=Range("DM194"), Order1:=xlAscending, _

Key2:=Range("DN194"), Order2:=xlAscending, _

Key3:=Range("DO194"), Order3:=xlAscending, _

Header:=xlNo

Set Rng2 = Intersect(Rng, .UsedRange)

For x = 1 To Rng2.Rows.Count

CompareString = _

.Cells(x + Rng2.Row - 1, 117) & "|" & _

.Cells(x + Rng2.Row - 1, 118) & "|" & _

.Cells(x + Rng2.Row - 1, 119)

If IsError(Application.Match(CompareString, MyArr3, 0)) Then

Counter = Counter + 1

If Counter = 1 Then

ReDim MyArr3(1 To Counter)

ReDim MyArr4(1 To Counter)

Else

ReDim Preserve MyArr3(1 To Counter)

ReDim Preserve MyArr4(1 To Counter)

End If

MyArr3(Counter) = CompareString

MyArr4(Counter) = Intersect(Rng2, .Rows(x + Rng2.Row - 1))

End If

Next x

Rng2.ClearContents

For x = 1 To Counter

.Cells(x + Rng2.Row - 1, 117).Resize(1, 3) = MyArr4(x)

Next x

End With

End Sub</pre>

This code could be structured better, but we can refine it when it does as you want.