Самый быстрый способ передачи больших объемов данных между листами

Question

В настоящее время у меня есть 2 рабочих листа, для простоты давайте назовем их Sheet1 и Sheet2 в пояснениях.В Sheet1 у меня есть около 50 тысяч строк данных.Я пытаюсь пройти через Sheet1 и найти уникальные вхождения в наборе данных, чтобы затем передать их на Sheet2.

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

Метод A - Итерация по Sheet1 с циклом For с условной проверкой, запрограммированной в VBA, если условие выполнено - перенести диапазон из 8 ячеек в этой строке в Sheet2.Этот метод завершает 60% за 60 минут.

Метод B - Я думал, что удаление проверки условия в VBA может ускорить процесс, поэтому я создал новый столбец в Sheet1 с оператором IF, который возвращает "Y "если условие выполнено.Затем я перебираю этот столбец и, если есть "Y", переношу вхождение в Sheet2.Это странно занимает больше времени, чем метод А, а именно 50% за 60 минут.

Sub NewTTS()

Dim lRow1 As Long, lRow2 As Long
Dim i As Long

With wsOTS

    lRow1 = .Range("E" & .Rows.Count).End(xlUp).Row

    For i = lRow1 To 2 Step -1
        If .Range("P" & i).Text = "Y" Then
            lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1

            wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = .Range("E" & i, "AA" & i).Value
        End If
    Next i

End With

End Sub

Метод C - затем я прочитал в другом посте, что метод .Find() быстрее, чем использование метода For loop.В качестве такового я использовал .Find() в столбце, который возвращает «Y», а затем перенес событие на Sheet2.На данный момент это самый быстрый метод, но он завершает только 75% за 60 минут.

Sub SearchOTS()

Application.ScreenUpdating = False

Dim startNumber As Long
Dim lRow1 As Long, lRow2 As Long
Dim i As Long
Dim startTime As Double

startTime = Time

lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row

Columns("P:P").Select

Selection.Find(What:="Y", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False).Activate

startNumber = ActiveCell.Row

lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1

wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = wsOTS.Range("E" & ActiveCell.Row, "AA" & ActiveCell.Row).Value

For i = 1 To lRow1
    Selection.FindNext(After:=ActiveCell).Activate

    If ActiveCell.Row = startNumber Then GoTo ProcessComplete

    lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1

    wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = wsOTS.Range("E" & ActiveCell.Row, "AA" & ActiveCell.Row).Value

    wsOTS.Range("B18").Value = i / lRow1
Next i

ProcessComplete:

Application.ScreenUpdating = True
MsgBox "Complete! Time taken: " & Format(Time - startTime, "hh:mm:ss")

End Sub

Метод D - я прочитал другой пост, в котором говорилось, что самым быстрым способом было бы построить массив, а затем перебрать массив.Вместо массива я использовал коллекцию (динамическую) и перебираю Sheet1 и сохраняю номера строк для вхождений.Затем я перебираю коллекцию и переношу события в Sheet2.Этот метод возвращает 50% за 60 минут.

Sub PleaseWork()

Dim i As Long
Dim lRow1 As Long, lRow2 As Long
Dim myCol As New Collection

lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row

'build collection of row numbers
For i = 1 To lRow1
    If wsOTS.Range("P" & i).Text = "Y" Then
        myCol.Add i
    End If
Next i

'now go through collection and build TTS
For i = 1 To myCol.Count
    lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1
    wsTTS.Range("E" & lRow2, "N" & lRow2).Value = wsOTS.Range("E" & myCol(i), "N" & myCol(i)).Value
Next i

Set myCol = New Collection

End Sub

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

Есть что-то, чего я здесь не хватает?Есть ли более быстрый метод?

Answer 1

Доступ к диапазону ужасно медленен и является причиной вашего длительного времени работы. Если вы уже знаете, что собираетесь читать 1000 строк, не читайте их по одному. Вместо этого вытащите весь диапазон в буфер, а затем работайте только с этим буфером. То же самое касается письма. Если вы не знаете заранее, сколько вы напишете, сделайте куски, например. Длина 100 строк.

( Не проверено ) пример:

Sub PleaseWork()

    Dim i As Long, j as long
    Dim lRow1 As Long, lRow2 As Long
    Dim myCol As New Collection
    Dim column_p() as variant
    dim inbuffer() as Variant
    dim outbuffer() as variant

    lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row
    ' Get whole Column P at once
    column_p = wsOTS.Range("P1").Resize(lRow1, 1).Value

    'build collection of row numbers
    For i = 1 To lRow1
        If column_p(i, 1) = "Y" Then
            myCol.Add i
        End If
    Next i

    'now go through collection and build TTS
    lRow2 = myCol.Count 'Number of required rows
    ' get whole input range
    inbuffer = wsOTS.Range("E1").Resize(lRow1, 10).Value
    ' prepare output
    ReDim outbuffer(1 to lRow2, 1 to 10)
    For i = 1 To myCol.Count
        ' write into outbuffer
        for j = 1 to 10
            outbuffer(i, j) = inbuffer(myCol(i), j)
        Next
    Next i

    ' Set whole output at once
    wsTTS.Range("E1").Resize(lRow2, 10).Value = outbuffer

    Set myCol = New Collection

End Sub

Answer 2

вы рассматривали возможность использования удаления дубликатов .

Шаги:

• Копировать все данные на новый лист
• На вкладке «Данные» выберите «Удалить дубликаты»

Вы также можете записать это как макрос.