Форум по VBA, Excel и Word

Sub CopyInfo()
   
    Dim sh_Nal As Worksheet, sh_arhiv As Worksheet
    Dim lr_Nal As Long, r As Long
    Dim counter As Long, i As Long

    ' Присваиваем листам имена 'sh_Nal' и 'sh_arhiv'. Далее в коде будем обращаться
        ' к листам по этим именам. Может быть так будет удобнее читать и писать код.
    Set sh_Nal = Worksheets("В наличии")
    Set sh_arhiv = Worksheets("Архив")
   
    lr_Nal = sh_Nal.Cells(sh_Nal.Rows.Count, 2).End(xlUp).Row 'вычисление номера строки
    If lr_Nal <= 2 Then
        MsgBox "Строк для обработки не выбрано" & Chr(13) & _
            " Для создания списка в столбце (Выбор) напишите букву а", vbCritical
        Exit Sub
    End If
   
    For i = 3 To lr_Nal 'Цикл со строки № 3 по последнюю заполненную (на активном листе)
        If sh_Nal.Cells(i, 2) = "а" Then 'Если ячейка столбца 2 текущей строки = "а", то
           
            ' Порядковый номер.
            counter = counter + 1
            r = sh_arhiv.Cells(sh_arhiv.Rows.Count, 3).End(xlUp).Row + 1 'определение последней заполненой строки на листе Архив
            sh_arhiv.Cells(r, 1).Value = counter
            sh_arhiv.Cells(r, 2).Value = sh_Nal.Cells(i, 3).Value
            sh_arhiv.Cells(r, 3).Value = sh_Nal.Cells(i, 4).Value
            sh_arhiv.Cells(r, 4).Value = "сони"
           
            counter = counter + 1
            r = r + 1
            sh_arhiv.Cells(r, 1).Value = counter
            sh_arhiv.Cells(r, 2).Value = sh_Nal.Cells(i, 7).Value
            sh_arhiv.Cells(r, 3).Value = "приложение к акту№ " & sh_Nal.Cells(i, 4).Value
            sh_arhiv.Cells(r, 4).Value = "сони"
           
            counter = counter + 1
            r = r + 1
            sh_arhiv.Cells(r, 1).Value = counter
            sh_arhiv.Cells(r, 2).Value = sh_Nal.Cells(i, 9).Value
            sh_arhiv.Cells(r, 3).Value = "приложение к акту№ " & sh_Nal.Cells(i, 4).Value
            sh_arhiv.Cells(r, 4).Value = "сони"
           
        End If
       
        sh_Nal.Cells(i, 2).ClearContents  'удаляем метку "a"
       
    Next i
 
    MsgBox "Перенос выполнен!", vbInformation
   
End Sub