Sub AwTest()
Dim j%, a%, b%, c%, r&, arr
Sheet1.Activate
arr = [a1].CurrentRegion
ReDim brr(1 To Rows.Count, 1 To 1)
For a = 1 To UBound(arr, 2) - 2
For b = a + 1 To UBound(arr, 2) - 1
For c = a + 2 To UBound(arr, 2)
If arr(1, a) < arr(1, b) And arr(1, b) < arr(1, c) Then
r = r + 1
brr(r, 1) = arr(1, a) & "," & arr(1, b) & "," & arr(1, c)
ElseIf arr(1, a) > arr(1, b) And arr(1, b) > arr(1, c) Then
r = r + 1
brr(r, 1) = arr(1, a) & "," & arr(1, b) & "," & arr(1, c)
End If
Next
Next
Next
[a12].Resize(r) = brr
End Sub |