ускорить Excel VBA копирование данных с одного листа на другой

Question

на одном листе у меня есть строки данных от столбца A до столбца L.

У меня есть макрос, который, учитывая пользовательский ввод, ищет строки, а затем копирует и вставляет эту строку в другой (изначальноЧистый лист.Поиск будет продолжен, каждый раз копируя и вставляя.К сожалению, иногда это требует копирования и вставки 500 строк.Excel начинает работать около 400 строк, очень медленно и часто просто падает.

Я прочитал Медленная запись макроса VBA в ячейках , но я не уверен, применимо ли это.

Будет ли создание коллекции номеров строк, полученной в результате моего поиска, с последующим циклическим просмотром, копированием и вставкой соответствующей строки, быстрее, чем копирование и вставка строки, как только она будет «найдена» (именно так она работает в настоящее время))?

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

edit:

nextblankrow=worksheets("findings").Range("A"&rows.count).End(xlup).row+1
Sheets("data").cells(J,1).EntireRow.copy sheets("findings").cells(nextblankrow,1)

, поэтому в приведенном выше коде первая строка находитСледующая пустая строка в листе «Выводы».Затем вторая строка копирует строку в листе «данных», которая, как было найдено, соответствует вводу пользователя в лист «выводов».

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

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

Answer 1

Speed ​​Up Copy / Paste Range

Если вы не знаете, отключение (False) значения Application.ScreenUpdating и особенно Application.Calculation также увеличит скорость выполнения вашего кода.

Union Range Version

Sub CopyRangeToSheetUnion()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range
  Const cIntColumn As Integer = 1          ' Source Search Column

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim rngU As Range      ' Union Range
  Dim i As Long          ' Source Range Row Counter

  With Worksheets(cVntSrc).Range(cStrSrcRange)

    ' Loop through each cell in column cIntColumn of Source Range and copy
    ' to Union Range if condition is met.
    For i = 1 To .Rows.Count
      If .Cells.Cells(i, cIntColumn).Value <> "" Then
        If Not rngU Is Nothing Then
          Set rngU = Union(rngU, .Cells(i, cIntColumn))
         Else
          Set rngU = .Cells(i, cIntColumn)
        End If
      End If
    Next

  End With

  ' Copy entire rows from Union range to Target Range.
  If Not rngU Is Nothing Then
    rngU.EntireRow.Copy Worksheets(cVntTgt).Range(cStrTgtCell)
    Set rngU = Nothing
  End If

End Sub

Array Version

Вот пример с условием, которое копирует каждую строку, в которой нет пустой ячейки в столбце «A»(В ближайшее время я опубликую образец с условием, используя метод Union).

Sub CopyRangeToSheetArray()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range
  Const cIntColumn As Integer = 1          ' Source Search Column

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim vntSrc As Variant  ' Source Array
  Dim vntTgt As Variant  ' Target Array
  Dim i As Long          ' Source Array Row Counter
  Dim j As Integer       ' Source/Target Array Column Counter
  Dim k As Long          ' Target Array Column Count/Counter

  ' Paste the Source Range into Source Array.
  vntSrc = Worksheets(cVntSrc).Range(cStrSrcRange)

  ' Count the number of rows that meet the condition.
  For i = 1 To UBound(vntSrc)
    If vntSrc(i, cIntColumn) <> "" Then
      k = k + 1
    End If
  Next

  ' Resize Target Array.
  ReDim vntTgt(1 To k, 1 To UBound(vntSrc, 2))

  ' Reset Target Array Column Counter
  k = 0

  ' Write from Source to Target Array.
  For i = 1 To UBound(vntSrc)
    If vntSrc(i, cIntColumn) <> "" Then
      k = k + 1
      For j = 1 To UBound(vntSrc, 2)
        vntTgt(k, j) = vntSrc(i, j)
      Next
    End If
  Next

  ' Paste Target Array into Target Worksheet
  Worksheets(cVntTgt).Range(cStrTgtCell) _
      .Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt

End Sub

Закуска

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

Sub CopyRangeToSheet()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim vntSrc As Variant  ' Source Array

  With Worksheets(cVntSrc)
    vntSrc = .Range(cStrSrcRange)
    Worksheets(cVntTgt).Range(cStrTgtCell) _
        .Resize(UBound(vntSrc), UBound(vntSrc, 2)) = vntSrc
  End With

End Sub