Option Explicit
Sub test()
Dim i, j, s As Integer
Dim x As String
Dim arrXA() As Integer
Dim arrGodi As Variant

arrGodi = Array(25, 42, 59, 76, 93) 'столбцы в которых будет искаться информация


For s = LBound(arrGodi) To UBound(arrGodi)

'вначале запомним в какие строки не пустые. В них по идее содержиться информация о ХА
For i = 5 To 3685
        Sheets("Лист2").Select 'указываем лист от куда копируем
        x = ActiveSheet.Cells(i, arrGodi(s)).Value
        If x <> "" Then
            'проверяем, что массив инициализирован
            If IsNotEmptyArray(arrXA) Then
                'расширяем массив на 1 элемент
                ReDim Preserve arrXA(UBound(arrXA) + 1)
            Else
                'инициализируем массив первым элементом
                ReDim Preserve arrXA(0)
            End If
            'присваиваем элементу массива строку где содержится информация
            arrXA(UBound(arrXA)) = i
        End If
Next i

'теперь в строках запомненных в массиве arrXA пропишем значение ХА в конечной таблице
For j = LBound(arrXA) To UBound(arrXA)
    Sheets("лист1").Select 'указываем лист куда вставляем
    ActiveSheet.Cells(arrXA(j), arrGodi(s)).Value = "ХА"
Next j
Next s
End Sub

'функция проверки существования массива
Function IsNotEmptyArray(parArray As Variant) As Boolean
  On Error Resume Next
  IsNotEmptyArray = LBound(parArray) <= UBound(parArray)
End Function