Страницы: 1
RSS
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
 
Изменено: Spec - 26.07.2020 09:41:39
 
Запускать при открытом листе ААА, обе книги д.б. открыты
Код
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
Изменено: Kuzmich - 26.07.2020 12:14:55
 
Spec,  макрос в какой книге должен находиться?
 
Юрий М, Макрос в книге "A" находится.
 
Ускоряемся. Макрос в книге А, она активна. Обе книги должны быть открыты:
Код
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
 
Kuzmich, 5 строка Вашего кода .Cells(2 * (i - 2) + 2, "D"), здесь (2 - это ячейка D2 ?           Еще i- 2 -это что?
Изменено: Spec - 26.07.2020 11:27:58
 
Юрий М, Круто. работает. Для понимания кода, не могли бы написать, что изменить, чтобы перескок при вставке был не через одну строку в Workbook "B", а сразу через 2 строки ?
 
+2 = через одну строку.
+3 = через 2 строки ))
Ну и размер выгружаемого массива тоже нужно будет изменить: умножить не на 2, а на 3.
 
Юрий М, Спасибо. 10 баллов из 10.
 
Юрий М,   Здравствуйте.

А Если код будет находиться в книге В?

Код
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

Большое спасибо.
Изменено: Wedimak - 06.05.2022 23:15:00
Страницы: 1
Наверх