Hi Petya,
try it
Sub ertert()
Dim x, y(), i&, j&, k&, n&
x = Sheets("before").Range("A1").CurrentRegion.Value
With Sheets("after")
.Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
End With
ReDim y(1 To 10000, 1 To 3)
For i = 2 To UBound(x)
For j = 2 To UBound(x, 2)
If x(i, j) = 1 Then
For n = j + 1 To UBound(x, 2)
If x(i, n) = 1 Then
k = k + 1
If k > 9999 Then
Sheets("after").Cells(Rows.Count, 1).End(xlUp)(2).Resize(k, 3).Value = y()
k = 1
End If
y(k, 1) = x(i, 1): y(k, 2) = x(1, j): y(k, 3) = x(1, n)
End If
Next n
End If
Next j
Next i
With Sheets("after")
.Cells(Rows.Count, 1).End(xlUp)(2).Resize(k, 3).Value = y(): .Activate
End With
End Sub
Bookmarks