Автор Тема: Excel VBA Макросы: копирование по условию  (Прочитано 175 раз)

Оффлайн vasa

  • Посетитель форума
  • Сообщений: 26
Как скопировать данные из одного листа на другой?
И ещё надо для некоторых ячеек сформировать данные.

Онлайн Администратор

  • Administrator
  • Сообщений: 1657
Re: Excel VBA Макросы: копирование по условию
« Ответ #1 : 14 Апрель 2019, 16:50 »
Макрос
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

Оффлайн vasa

  • Посетитель форума
  • Сообщений: 26
Re: Excel VBA Макросы: копирование по условию
« Ответ #2 : 14 Апрель 2019, 17:06 »
Спасибо, большое. То что хотел.