Страницы: 1
RSS
Копирование данных столбца в строку из одного листа в другой
 
Добрый вечер всем !

Как реализовать макросом следующее:

Данные  по макросу с Лист 1 копируются на Лист 2 по следующему условию:
Каждые 3 строки столбца А на Лист1 (начиная с ячейки А1 Лист1)
копируются в одну строку на Лист2 (начиная с ячейки А2 Лист2)

Отметил цветом соответствующие ячейки Лист1 и Лист2 при копировании в примере.
 
Код
Sub ПереносДанных()
Dim lastrow&, i&
    Application.ScreenUpdating = 0
    With Worksheets("Лист1")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 1 To lastrow Step 3
            .Range(.Cells(i, 1), .Cells(i + 2, 1)).Copy
            With Worksheets("Лист2")
                lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                .Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            End With
        Next i
    End With
    Application.ScreenUpdating = 1
End Sub
Изменено: Михаил О. - 07.08.2020 18:04:05
Я не Михаил...
 
Благодарю Михаил !   Работает (правда медленно при большей таблице - но работает)
Изменено: serg555 - 07.08.2020 18:10:51
 
я обновил код, скопируйте заново
Я не Михаил...
 
Вариант. Только заполните заголовки на втором листе
Код
Sub ПереносДанных()
Dim i As Long, LastRow As Long, FreeRow As Long, iCol As Long
    With Sheets("Лист2")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(LastRow + 1, 3)).ClearContents
        FreeRow = 2
        iCol = 1
        LastRow = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To LastRow
            .Cells(FreeRow, iCol) = Cells(i, 1)
            iCol = iCol + 1
            If iCol = 4 Then
                iCol = 1
                FreeRow = FreeRow + 1
            End If
        Next
    End With
End Sub
 
Насколько большая таблица?
 
До 1000 строк . Благодарю Юрий за помощь - быстро копируется !
 
Можно заметно ускорить. Писать код?
 
serg555,
Код
Option Base 1

Sub copy_3_3()
Dim i As Long, lr As Long, n As Long, k As Long
Dim arr()
Dim arr2() As String
Worksheets(2).Range("A:C").Clear
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:A" & lr)
s = 3
ReDim arr2(lr / s, 1 To s)
k = 1
For i = LBound(arr) To UBound(arr)
    For n = 1 To s
        arr2(k, n) = arr(i, 1)
        i = i + 1
    Next n
k = k + 1
i = i - 1
Next i
Worksheets(2).Range("A2", Worksheets(2).Cells(lr / s + 1, 3)) = arr2()
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
На старых переменных )
Код
Sub ПереносДанных()
Dim i As Long, LastRow As Long, FreeRow As Long, iCol As Long, Arr(), ArrOut
    FreeRow = 1
    iCol = 1
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Arr = Range(Cells(1, 1), Cells(LastRow, 1)).Value
    ReDim ArrOut(1 To UBound(Arr), 1 To 3)
    For i = 1 To UBound(Arr)
        ArrOut(FreeRow, iCol) = Arr(i, 1)
        iCol = iCol + 1
        If iCol = 4 Then
            iCol = 1
            FreeRow = FreeRow + 1
        End If
    Next
    With Sheets("Лист2")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(LastRow + 1, 3)).ClearContents
        .Range("A2").Resize(UBound(ArrOut), 3).Value = ArrOut
    End With
End Sub
 
Спасибо всем большое за поддержку !
Страницы: 1
Наверх