Excel VBA Optimize Cycle

Question

Прошу прощения, если уже существует аналогичный вопрос, но если да, я не нашел.

Я новичок в программировании в VBA и до сих пор не знаю многого, теперь я пытаюсь запустить функцию, которая проверяет, повторяются ли в столбце «B» ведомости, и если существует, будет проверяться столбец «C», где самое высокое значение, копирование нижней таблицы в другую и ее удаление.

Код уже делает все это, однако необходимо запустить в таблицах с 65 000 строк, и для запуска этих таблиц требуется много времени, так как даже при работе в таблицах с 5000 или 10000 строк занимает примерно 6 15 минут.

Мой вопрос в том, есть ли какой-либо способ оптимизировать цикл, который я использую, лучше использовать для каждого или поддерживать Do While Loop?

Вот код, я использую:

Function Copy() 

    Worksheets("Sheet1").Range("A1:AQ1").Copy _ 
    Destination:=Worksheets("Sheet2").Range("A1") 

    Dim lRow As Long 
    Dim lRow2 As Long 
    Dim Row As Long 
    Dim countA As Long 
    Dim countB As Long 
    Dim t As Double 

    lRow = 5000 
    Row = 2 
    countA = 0 
    countB = 0 

    Application.ScreenUpdating = False 
    ViewMode = ActiveWindow.View 
    ActiveWindow.View = xlNormalView 
    Application.EnableEvents = False 
    Application.DisplayStatusBar = False 

    ActiveSheet.DisplayPageBreaks = False 
    lRow2 = lRow - 1 
    t = Timer 

    Do While lRow > 2 


      If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then 

       lRow = lRow - 1 
       lRow2 = lRow - 1 

      Else 

       If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then 

        Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row) 
        Rows(lRow2).Delete 
        lRow = lRow - 1 
        Row = Row + 1 
        countA = countA + 1 


       Else 

        Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row) 
        Rows(lRow).Delete 
        lRow = lRow - 1 
        Row = Row + 1 
        countB = countB + 1 

       End If 

       lRow2 = lRow2 - 1 

      End If 

    Loop 

    Application.DisplayStatusBar = True 
    ActiveWindow.View = ViewMode 
    Application.ScreenUpdating = False 
    MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t)/60 

End Function 

Answer 1

До тех пор, как вы вошли в среду VBA для решения, кажется, мало смысла в не продолжает эту аллею в сторону оптимального маршрута возможно. Следующая версия использует пару Scripting.Dictionaries для создания двух наборов данных из исходной матрицы в Sheet1. В дополнение к основной подпроцедуре имеются две короткие «вспомогательные» функции, которые нарушают барьер 65536, от которого страдают Application.Index и Application.Transpose. Они необходимы, чтобы очистить строку от большого двумерного массива и перевернуть ориентацию результатов при одновременном разделении сохраненных записей.

Sub Keep_Highest_BC() 
    Dim d As Long, dHIGHs As Object, dDUPEs As Object 
    Dim v As Long, vTMPs() As Variant, iCOLs As Long 

    Debug.Print Timer 
    'On Error GoTo bm_Safe_Exit 
    Set dHIGHs = CreateObject("Scripting.Dictionary") 
    Set dDUPEs = CreateObject("Scripting.Dictionary") 

    With Worksheets("Sheet1") 
     iCOLs = .Columns("AQ").Column 
     .Cells(1, 1).Resize(2, iCOLs).Copy _ 
      Destination:=Worksheets("Sheet2").Cells(1, 1) 
     With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs) 
      vTMPs = .Value2 
     End With 
    End With 

    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1) 
     If dHIGHs.exists(vTMPs(v, 2)) Then 
      If CDbl(Split(dHIGHs.Item(vTMPs(v, 2)), ChrW(8203))(2)) < vTMPs(v, 3) Then 
       dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=dHIGHs.Item(vTMPs(v, 2)) 
       dHIGHs.Item(vTMPs(v, 2)) = joinAtoAQ(vTMPs, v) 
      Else 
       dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v) 
      End If 
     Else 
      dHIGHs.Add Key:=vTMPs(v, 2), Item:=joinAtoAQ(vTMPs, v) 
     End If 
    Next v 

    With Worksheets("Sheet1") 
     With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs) 
      .ClearContents 
      With .Resize(dHIGHs.Count, iCOLs) 
       .Value = transposeSplitLargeItemArray(dHIGHs.items) 
      End With 
     End With 
    End With 

    With Worksheets("Sheet2") 
     With .Cells(1, 1).CurrentRegion.Offset(1, 0) 
      .ClearContents 
      With .Resize(dDUPEs.Count, iCOLs) 
       .Value = transposeSplitLargeItemArray(dDUPEs.items) 
       .Rows(1).Copy 
       .PasteSpecial Paste:=xlPasteFormats 
       Application.CutCopyMode = False 
      End With 
     End With 
    End With 

bm_Safe_Exit: 
    dHIGHs.RemoveAll: Set dHIGHs = Nothing 
    dDUPEs.RemoveAll: Set dDUPEs = Nothing 

    Debug.Print Timer 
End Sub 

Function joinAtoAQ(vTMP As Variant, ndx As Long) 
    Dim sTMP As String, v As Long 

    For v = LBound(vTMP, 2) To UBound(vTMP, 2) 
     sTMP = sTMP & vTMP(ndx, v) & ChrW(8203) 
    Next v 
    joinAtoAQ = Left$(sTMP, Len(sTMP) - 1) 
End Function 

Function transposeSplitLargeItemArray(vITMs As Variant) 
    Dim v As Long, w As Long, vTMPs As Variant, vITM As Variant 

    ReDim vTMPs(LBound(vITMs) To UBound(vITMs), LBound(vITMs) To UBound(Split(vITMs(LBound(vITMs)), ChrW(8203)))) 
    For v = LBound(vITMs) To UBound(vITMs) 
     vITM = Split(vITMs(v), ChrW(8203)) 
     For w = LBound(vITM) To UBound(vITM) 
      vTMPs(v, w) = vITM(w) 
     Next w 
    Next v 

    transposeSplitLargeItemArray = vTMPs 
End Function 

После того, как два словаря были заполнены максимальными значениями и дублировать меньшие значения, массивы возвращаются в двух листах скопом, а затем разделить обратно в 43 столбцов. Сделаны последние попытки восстановить исходное форматирование из Sheet1 в область данных Sheet2.

I tested this on 75,000 rows of columns A through column AQ containing random sample data first with predominantly duplicate values in column B and then with roughly half duplicate values in column B. The first single pass was processed in 13.19 seconds; the second in 14.22. While your own results will depend on the machine you are running it on, I would expect a significant improvement over your original code. Post your own timed results (start and stop in seconds within the VBE's Immediate window, Ctrl+G) into the comments if you can.

Answer 2

Обычно это быстрее, чтобы выполнить одно удаление в конце цикла.

Непроверенные:

Function Copy() 

    Dim shtSrc As Worksheet, shtDest As Worksheet 
    Dim lRow As Long, Row As Long, viewmode 
    Dim countA As Long, countB As Long 
    Dim t As Double, rw As Range, rngDel As Range 

    lRow = 5000 
    Row = 2 
    countA = 0 
    countB = 0 

    Set shtSrc = Worksheets("Sheet1") 
    Set shtDest = Worksheets("Sheet2") 

    shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1") 

    Application.ScreenUpdating = False 
    viewmode = ActiveWindow.View 
    ActiveWindow.View = xlNormalView 
    Application.EnableEvents = False 
    Application.DisplayStatusBar = False 

    ActiveSheet.DisplayPageBreaks = False 

    t = Timer 

    Do While lRow > 2 

      Set rw = shtSrc.Rows(lRow) 

      If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then 

       If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then 
        rw.Offset(-1, 0).Copy shtDest.Rows(Row) 
        AddToRange rngDel, rw.Offset(-1, 0) 
        countA = countA + 1 
       Else 
        rw.Copy shtDest.Rows(Row) 
        AddToRange rngDel, rw 
        countB = countB + 1 
       End If 

       Row = Row + 1 

      End If 

      lRow = lRow - 1 

    Loop 

    'anything to delete? 
    If Not rngDel Is Nothing Then 
     rngDel.Delete 
    End If 

    Application.DisplayStatusBar = True 
    ActiveWindow.View = viewmode 
    Application.ScreenUpdating = False 
    MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t)/60 

End Function 

'utility sub for building up a range 
Sub AddToRange(rngTot, rng) 
    If rngTot Is Nothing Then 
     Set rngTot = rng 
    Else 
     Set rngTot = Application.Union(rng, rngTot) 
    End If 
End Sub