Пожалуйста, посоветуйте сделать код более эффективным для выполнения

Question

В настоящее время я работаю над файлом, в который данные из определенных ячеек копируются и вставляются на другой лист таблицы.

Мой текущий код VBA копирует данные и ищет ячейку, в которую нужно вставить, ноесли в ячейке назначения в настоящий момент есть значение, оно циклически проверяет последующие строки в том же столбце, пока не найдет пустую ячейку.Таким образом, если в таблице в настоящий момент находится 2000 строк данных, она будет искать все 2000 ячеек, прежде чем попасть в 2001-ю строку и т. Д.

Время, необходимое для выполнения кода, зависит от размераТаблица.

Можно ли как-нибудь ускорить выполнение этой команды?

Ниже приведен пример копирования данных из двух ячеек.

Sub Test()
Sheets("Sheet1").Select
Range("K10").Select
Selection.Copy
Sheets("Table").Select
Range("A2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Range("G15").Select
Selection.Copy
Sheets("Table").Select
Range("B2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
End sub

Answer 1

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

Sub Test()

    Dim ws1 As Worksheet

    Set ws1 = Worksheets("sheet1")

    With Worksheets("table")
        'force a definition for a .UsedRange on the worksheet
        .Cells(.Rows.Count, "A") = Chr(32)
        .Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(10, "K").Value
        .Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(15, "G").Value
        'clear the artificial .UsedRange
        .Cells(.Rows.Count, "A").Clear
        'Debug.Print .UsedRange.Address(0, 0)
    End With

End Sub

Answer 2

Попробуйте следующий подпункт

Sub CopyPaste()
Dim sht1, sht2 As Worksheet

Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Table")

    sht1.Range("K10").Copy sht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    sht1.Range("G15").Copy sht2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)

End Sub