Option Explicit

Sub FindAndAppendRows()
    Dim i&, n&

    With ThisWorkbook.Worksheets("BASE")

        Dim lrB     As Long
        lrB = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lrB < 4 Then Exit Sub

        Dim a       As Variant
        a = .Range("A4:H" & lrB).Value
    End With

    Dim r()         As Variant
    ReDim r(1 To UBound(a), 1 To 7)

    For i = 1 To UBound(a)

        If InStr(1, Replace$(a(i, 1), " ", ""), "Крд003", vbTextCompare) Then
            n = n + 1

            r(n, 1) = a(i, 1)
            r(n, 2) = a(i, 3)
            r(n, 3) = a(i, 4)
            r(n, 4) = a(i, 5)
            r(n, 5) = a(i, 6)
            r(n, 6) = a(i, 7)
            r(n, 7) = a(i, 8)
        End If

    Next i

    If n = 0 Then Exit Sub

    With ThisWorkbook.Worksheets("1")

        '        ' 1). Вариант если всегда хотите внести данные с новой (пустой) строки и вниз при повторном запуске макроса
        '        Dim lrR     As Long
        '        lrR = .Cells(.Rows.Count, 1).End(xlUp).Row + 1

        '        .Range("A" & lrR).Resize(n, 7).Value = r

        ' 2). Вариант если всегда хотите внести данные в ячейку A3 при повторном запуске макроса
        .Range("A3:G" & .Rows.Count).ClearContents
        .Range("A3").Resize(n, 7).Value = r
    End With

End Sub