Subscript out of range error(For karedog)

ricklou, try this modified code according to new data layout :

Sub KaredogMac2()
  Dim a(), b(), c As New Collection, d As New Collection, i As Long, x As String, y As String, z As String, v1, v2, v3
  Sheet1.Select
  a = Range("A1").CurrentRegion.Resize(, 2).Value
  b = Range("F1:H" & Cells(Rows.Count, "F").End(xlUp).Row).Value
  For i = 2 To UBound(a, 1)
      x = Trim$(a(i, 2))
      If Len(x) Then
         On Error Resume Next
            c.Add Key:=x, Item:=New Collection
         On Error GoTo 0
         c(x).Add a(i, 1)
      End If
  Next i
  For i = 1 To UBound(b, 1)
      x = Trim$(b(i, 1))
      y = Trim$(b(i, 2))
      z = Trim$(b(i, 3))
      If Len(x) * Len(y) * Len(z) Then
         On Error Resume Next
            Set v1 = c(x)
            Set v1 = c(y)
            Set v1 = c(z)
            If Err.Number <> 0 Then
               On Error GoTo 0
               GoTo skipper
            End If
         On Error GoTo 0
         For Each v1 In c(x)
             For Each v2 In c(y)
                 For Each v3 In c(z)
                     d.Add Array(v1, v2, v3)
                 Next v3
             Next v2
         Next v1
      End If
skipper:
  Next i
  ReDim a(1 To d.Count, 1 To 3)
  i = 0
  For Each v1 In d
      i = i + 1
      a(i, 1) = v1(0)
      a(i, 2) = v1(1)
      a(i, 3) = v1(2)
  Next v1
  Range("N2").Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

If you want to change data from columns F-G-H to I-J-K, then change this code as well :

'b = Range("F1:H" & Cells(Rows.Count, "F").End(xlUp).Row).Value
b = Range("I1:K" & Cells(Rows.Count, "I").End(xlUp).Row).Value

You are welcome, thanks for marking the thread as solved and rep.points.

Regards