Option Explicit
Sub xxxxx()
Dim LastRow As Long, i As Long, n As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Range("B4:AL" & LastRow).ClearContents
For i = 4 To LastRow
  For n = 2 To 38
     If Cells(i, 1).Value = Cells(3, n).Value Then
        Cells(i, n).Value = "x"
        Exit For
     End If
  Next
Next
 
End Sub

Option Explicit
Sub xxxxx()

Dim LastRow As Long, i As Long
Dim n As Long, ID As Integer, rng As Range, firstAddress As String
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

With Range("A3:A" & LastRow)
   For n = 2 To 38
       ID = Cells(3, n)
       Set rng = .Find(What:=ID, LookAt:=xlWhole, LookIn:=xlValues)
       If Not rng Is Nothing Then
          firstAddress = rng.Address
          Do
          Cells(rng.Row, n).Value = "x"
         Set rng = .FindNext(rng)
         Loop While Not rng Is Nothing And rng.Address <> firstAddress
       End If
    Next n
 End With

End Sub

Option Explicit

Sub Test_Ricerca()
  Dim LastRow As Long, i As Long, n As Long
  Dim rngK, rngL, arr(), x
  LastRow = Cells(Rows.Count, 1).End(xlUp).Row
  rngK = Range("A4:A" & LastRow)
  ReDim arr(1 To UBound(rngK), 1 To 37)
  rngL = Range("B3:AL3")
  For i = 1 To UBound(rngK, 1)
    x = rngK(i, 1)
    For n = 1 To UBound(rngL, 2)
       If x = rngL(1, n) Then
          arr(i, n) = "x"
          Exit For
       End If
    Next
  Next
  Range("B4:AL" & LastRow) = arr
End Sub