VBA копирует строки быстро

Question

Мне нужно работать с файлами с 5000 строк, для каждой строки мне нужно вставить еще 3 строки и скопировать содержимое в эти новые строки (после этого будет больше шагов). Мой макрос работает нормально, но процесс копирования контента очень медленный, я уверен, что есть решение, которое работает лучше, есть идеи?

Sub copy_rows()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrow = Lastrow * 4

For i = 1 To Lastrow Step 4
Cells(i, 7).EntireRow.Offset(1).Resize(3).Insert Shift:=xlDown
Rows(i).Copy Destination:=Rows(i + 1)
Rows(i).Copy Destination:=Rows(i + 2)
Rows(i).Copy Destination:=Rows(i + 3)
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub

Большое спасибо

Answer 1

Когда дело доходит до скорости:
Медленный доступ к данным Excel в VBA, вставка строки (или столбца) безумно медленная, в то время как все, что делается в памяти (переменные VBA), настолько быстро, что вы почти не можете измерить ее.

Поэтому я предлагаю прочитать все данные из вашего рабочего листа в память, «умножить» там строки и записать все обратно сразу.

Следующий пример кода считывает данные в2-мерный массив и скопируйте его во 2-й массив, который в 4 раза больше.Этот 2-й массив записывается обратно на лист.Я протестировал его с 1000 строк и время выполнения было 0 с.

Недостаток: возможно, вам придется позаботиться о форматировании

With ActiveSheet
    Dim lastRow As Long, lastCol As Long

    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).row

    Dim origData, copyData
    origData = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))  ' Read data from sheet
    ReDim copyData(1 To lastRow * 4, 1 To lastCol)             ' new array is 4 times the size
    Dim r As Long, c As Long, i As Long
    For r = 1 To lastRow           ' All rows in orig data
        For c = 1 To lastCol       ' All columns in orig data
            For i = 1 To 4         ' Copy everything 4 times
                copyData((r - 1) * 4 + i, c) = origData(r, c)
            Next i
        Next c
    Next r
    .Range(.Cells(1, 1), .Cells(lastRow * 4, lastCol)) = copyData  ' Write back to sheet

End With

Answer 2

FunThomas - это правильно, и это должно быть самым быстрым способом, но если это не вариант, гораздо быстрее не копировать всю строку.

Определение диапазона и простое копирование данных в эти ячейкиданных больше, чем тысячи столбцов в таблице, и я сомневаюсь, что ваша таблица использует их все.

Также, как сказал Витая, быстрее скопировать значения, и вы всегда можете выполнить массовое форматирование всего лота, если это потребуется.

Sub copy_rows2()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

dim c as integer
c = 10 'number of columns with data

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastRow = lastRow * 4

For i = 1 To lastRow Step 4

    'inserts 3 rows at a time    
    ActiveSheet.Rows(i + 1 & ":" & i + 3).Insert Shift:=xlDown         

    'copy data into new rows limited to number of columns c
    Range(Cells(i + 1, 1), Cells(i + 3, c)).Value = Range(Cells(i, 1), Cells(i, c)).Value

Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub

Answer 3

Пожалуй, самый быстрый способ, если вас не интересует формат, а только значения:

Sub TestMe()

    With Worksheets(1)
        .Rows(1).Value = .Rows(2).Value
    End With

End Sub