Try. Macro code :
Sub ReadTriplets()
Dim TH, CH, A
Dim Tr&, Tc&, T1&, T2&, T3&
Dim Rng As Range
If ActiveSheet.Name <> "Planilha1" Then Sheets("Planilha1").Activate
TH = Range("Q4:AN4"): CH = Range("AQ4:BN4"): A = Range("A5:O3018")
ReDim R1(1 To UBound(A, 1), 1 To UBound(TH, 2)): ReDim R2(1 To UBound(A, 1), 1 To UBound(CH, 2))
For Tr = 1 To UBound(A, 1)
For Tc = 1 To UBound(A, 2) - 2
For T1 = 1 To UBound(TH, 2) Step 3
If A(Tr, Tc) = TH(1, T1) And A(Tr, Tc + 1) = TH(1, T1 + 1) And A(Tr, Tc + 2) = TH(1, T1 + 2) Then
R1(Tr, T1) = "x": R1(Tr, T1 + 1) = "x": R1(Tr, T1 + 2) = "x"
End If
Next T1
For T2 = 1 To UBound(CH, 2) Step 3
Set Rng = Range("A5:O5").Offset(Tr - 1, 0)
If (WorksheetFunction.CountIf(Rng, CH(1, T2)) + WorksheetFunction.CountIf(Rng, CH(1, T2 + 1)) + WorksheetFunction.CountIf(Rng, CH(1, T2 + 2))) = 3 Then
R2(Tr, T2) = "x": R2(Tr, T2 + 1) = "x": R2(Tr, T2 + 2) = "x"
End If
Next T2
Next Tc
Next Tr
With Range("Q5").Resize(Tr - 1, T1 - 1)
.Clear
.Value = R1
End With
With Range("AQ5").Resize(Tr - 1, T2 - 1)
.Clear
.Value = R2
End With
End Sub
Bookmarks