VBA Цикл перебирает диапазон, копирует по одной ячейке и вставляет в конец другого диапазона в другом Workbook + 1 пустая строка, VBA, циклы, копирование, вставка, через строку
Добрый день. есть задача. 1) Из Excel файла A с помощью цикла осуществляем перебор ячеек диапазона. Диапазон ("C2:C4"). 2) Ячейку C2 из файла "A" копируем и вставляем в файл по наименованию B в ячейку D2. 3) Ячейку C3 из файла "A" копируем и вставляем в файл по наименованию B в ячейку D4. 4) Ячейку C4 из файла "A" копируем и вставляем в файл по наименованию B в ячейку D6. Все это делается с использованием циклов. Проблема в одновременном переборе циклом диапазона ячеек в файле A для копирования и цикла с определением последней строки + 1 для вставки.
Диапазон на самом деле содержит почти пару тысяч строк. Но его сократил для понимания задачи.
Помогите пожалуйста решить задачу.
Файлы примеров также прикреплены. Есть код (ниже), но не работает.
Код
Sub CopyPasteToNextEmptyCell()
Dim NextRow As Long
Dim MyRange As Range
Dim MyCell As Range
Set MyRange = Workbook("A").Sheets("AAA").Range("C2:C4")
For Each MyCell In MyRange
MyCell.Copy
Workbooks("B.xlsx").Sheets("BBB").Activate
Do
' Identification Next Empty Row
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Workbooks("B.xlsx").Sheets("BBB").Cells(NextRow, 1).Paste
Loop
Exit Do
Next MyCell
End Sub
Запускать при открытом листе ААА, обе книги д.б. открыты
Код
Sub Perenos()
Dim i As Long
With Workbooks("B.xlsx").Worksheets("BBB")
For i = 2 To 4
Cells(i, "C").Copy .Cells(2 * (i - 1) , "D")
Next
End With
End Sub
Ускоряемся. Макрос в книге А, она активна. Обе книги должны быть открыты:
Код
Sub Macro1()
Dim LastRow As Long, i As Long, Arr(), ArrOut, x As Long
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Arr = Range(Cells(2, 3), Cells(LastRow, 3)).Value
ReDim ArrOut(1 To UBound(Arr) * 2, 1 To 1)
x = 1
For i = 1 To UBound(Arr)
ArrOut(x, 1) = Arr(i, 1)
x = x + 2
Next
Workbooks("B").Sheets("BBB").Range("D2").Resize(x - 2, 1).Value = ArrOut
End Sub
Юрий М, Круто. работает. Для понимания кода, не могли бы написать, что изменить, чтобы перескок при вставке был не через одну строку в Workbook "B", а сразу через 2 строки ?
Sub Macro1()
Dim LastRow As Long, i As Long, Arr(), ArrOut, x As Long
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Arr = Range(Cells(2, 3), Cells(LastRow, 3)).Value
ReDim ArrOut(1 To UBound(Arr) * 2, 1 To 1)
x = 1
For i = 1 To UBound(Arr)
ArrOut(x, 1) = Arr(i, 1)
x = x + 2
Next
Workbooks("B").Sheets("BBB").Range("D2").Resize(x - 2, 1).Value = ArrOut
End Sub