самый эффективный метод VBA для копирования данных с одного листа на другой

Question

Я просто пытаюсь выполнить простое копирование с одного листа Excel на другой, но программа, кажется, работает вечно.

n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))
ro = 3

For i = 4 To n + 4
    If Len(Trim(WAEnv.Cells(i, 1).Value)) > 0 Then
       ro = ro + 1
       WAPatch.Cells(ro, 1).RowHeight = WAEnv.Cells(i, 1).RowHeight
       WAPatch.Cells(ro, 1).Value = Trim(WAEnv.Cells(i, 1).Value)
       WAPatch.Cells(ro, 2).Value = Trim(WAEnv.Cells(i, 2).Value)
       WAPatch.Cells(ro, 3).Value = Trim(WAEnv.Cells(i, 3).Value)
       WAPatch.Cells(ro, 4).Value = Trim(WAEnv.Cells(i, 4).Value)
       WAPatch.Cells(ro, 5).Value = Trim(WAEnv.Cells(i, 5).Value)
    End If
Next i

Есть ли более быстрый или эффективный способ сделать это?

Answer 1

Если цель для установки RowHeight может быть принесена в жертву, то можете попробовать следующий код (очевидно, после изменения листов, диапазонов, соответствующих вашим требованиям)

Sub test()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer

Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")

Set Rng = WAEnv.Range("A4:E" & WAEnv.Cells(Rows.Count, 1).End(xlUp).Row)
SrcArr = Rng.Value
Xrow = 1
Chunk60K = 0

    For Rw = 1 To UBound(SrcArr, 1)
        If SrcArr(Rw, 1) > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
            For Xcol = 1 To 5
            DstArr(Xcol, Xrow) = SrcArr(Rw, Xcol)
            Next Xcol

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If

        End If
    Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

Коду требуется около 7-8 секунд для обработки около 300 К строк (около половины отфильтровано)

Поскольку я лично не предпочитаю отключать вычисления, обработку событий и обновление экрана (в обычных случаях), я не добавил эти стандартные строки. Однако вы можете использовать эти стандартные методы в зависимости от состояния рабочего файла.

Редактировать: добавление кода, включая настройку высоты строки (нестабильно после 150 К)

Sub test4()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer


Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")
'n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))

Lastrow = WAEnv.Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print Lastrow
Xrow = 1
Chunk60K = 0

        For Rw = 4 To Lastrow
        Set Rng = WAEnv.Range("A" & Rw & ":E" & Rw)
        If Rng(1, 1).Value > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
        Xcol = 1
            For Each cl In Rng.Columns.Cells
            DstArr(Xcol, Xrow) = cl.Value
            Xcol = Xcol + 1
            Next cl
        WAPatch.Cells(Xrow, 1).RowHeight = Rng(1, 1).RowHeight

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If
      End If
      Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

Answer 2

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

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

Наконец, если у вас большое количество пропусков и вы не возвращаетесь к исходному листу, выполните сортировку там перед копированием.Или примените фильтр и удалите ошибочные строки, хотя я нахожу это немного более привередливым.

Answer 3

n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))
ro = 3

For i = 4 To n + 4
    If Len(Trim(WAEnv.Cells(i, 1).Value)) > 0 Then
        ro = ro + 1
        WAEnv.range("A" & i & ":E" & i).copy
        WAPatch.range("A" & ro & ":E" & ro).pastespecial xlpastevalues
        With WAPatch.range("A" & ro & ":E" & ro)
            .Value = Evaluate("IF(ROW(" & .Address & "),CLEAN(TRIM(" & .Address & ")))")
        End With
    End if
Next

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

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