Evaluate 20k rows and copy to another sheet. Need different approach to speed it up.

[Mange08]

Hi,

I have an order report i run daily with around 20k rows with customer data, order quantity and order value. (I removed half of the data in the mockup file)
What i´m basically trying to do is copy the rows that is either incomplete in column K, or copy the rows which has a complete value in column P but no value in column S, to another sheet.

I tried to write an loop for it and it works, but considered it´s alot of rows it takes ~3-4minutes to evaluate whole range.
Is there a faster approach to this?

Sub fcat()
    Dim fcat As Variant, cell As Range
    Dim lRow As Long
    Dim RngOne As Range
    Dim StartTime As Double
    Dim SecondsElapsed As Double
   
    'Remember time when macro starts
    StartTime = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
   
    Set src = ThisWorkbook.Sheets("Data")
   
    Set tgt = ThisWorkbook.Sheets("SO 2017")
   
    ' hitta sista raden med data i kolumn A
    lRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
       
    'Töm tabellen med order för 2017
    With Sheet8.ListObjects("Table1")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.Delete
        End If
    End With
       
    ii = 2
   
    With Sheets("Data")
        Set RngOne = src.Range("A6:A" & lRow)
   
        For Each cell In RngOne
           
           
       
            If cell.Offset(, 15) > 0 And _
              cell.Offset(, 18) = 0 Or cell.Offset(, 18) = ISBLANK And cell.Offset(, 15) = 0 Then
             
             
              Range(cell.Offset(0, 0), cell.Offset(0, 9)).Copy (tgt.Range("A" & ii))
             
              If cell.Offset(, 15) > 0 Then
                    tgt.Range("L" & ii) = cell.Offset(, 15)
                    tgt.Range("K" & ii) = cell.Offset(, 12)
                   
              ElseIf cell.Offset(, 15) = 0 And cell.Offset(, 12) > 0 Then
                    tgt.Range("K" & ii) = cell.Offset(, 12)
               
              Else
             
                    tgt.Range("L" & ii) = cell.Offset(, 13)
                    tgt.Range("K" & ii) = cell.Offset(, 10)
              End If
           
            ii = ii + 1
           
            End If
       
        Next cell
    'Loop
    End With
         
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
   
    'Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 2)

    'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
   
     
End Sub

 

[NARAYANK991]

Hi ,

If you can explain your requirement in words , as clearly and comprehensively as possible , it will ensure that those who wish to help need not go through your posted code in order to understand your requirement.

Narayan

 

[Marc L]

Hi !

Is there a faster approach to this?

As always just use Excel inner features, faster than any gas factory code !
For example an advanced filter either manually or even by code …

• Introduction to Excel Advanced Filters
• Extract data using Advanced Filter and VBA

Many samples within threads of this forum …
​

 

[Mange08]

Ok, i try again
I want to check if the row has a value in column S
If it doesn't it needs to be copied to "table1" in sheet SO 2017.
What i i want to be copied is column A-J and then the correct pcs and value.
So from the picture i posted below, first yellow line needs to be copied A-J and 1440pcs 98879,98 , excluding column K,L,N,Q,R,S

Same with the third yellow line, except there i need the values from column K 240pcs and 12874,09 from column N.



Result

 

[Chihiro]

Hmm, Advanced Filter isn't suitable for this, since in result column L & K can have values from different source column.

One way to do it is to commit range into array and do operation in memory.

See sample code below.

Sub fcatDemo()
    Const myDelim As String = "^"
    Dim i As Long, j As Long
    Dim myArr, resArr, Key, x
    Dim tempArr(1 To 10)
    Dim sTime As Single, eTime As Single
    sTime = Timer
    OptimizeVBA True
    With Sheet8.ListObjects("Table1")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.Delete
        End If
    End With
    With Sheets("Data")
      myArr = .Range("A6:S" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
    End With
  
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(myArr)
            If myArr(i, 16) > 0 And myArr(i, 19) = 0 Or myArr(i, 19) = ISBLANK And myArr(i, 16) = 0 Then
                For j = 1 To 10
                    tempArr(j) = myArr(i, j)
                Next
                .Item(i) = Join(tempArr, myDelim)
                If myArr(i, 16) > 0 Then
                    .Item(i) = .Item(i) & myDelim & myArr(i, 16) & myDelim & myArr(i, 13)
                ElseIf myArr(i, 16) = 0 And myArr(i, 13) > 0 Then
                    .Item(i) = .Item(i) & myDelim & " " & myDelim & myArr(i, 13)
                Else
                    .Item(i) = .Item(i) & myDelim & myArr(i, 14) & myDelim & myArr(i, 11)
                End If
            End If
        Next
        ReDim resArr(1 To .Count, 1 To 12)
        i = 1
        For Each Key In .Keys
            x = Split(.Item(Key), myDelim)
            For j = LBound(x) To UBound(x)
                resArr(i, j + 1) = x(j)
            Next
            i = i + 1
        Next
      
        Sheet8.Range("A2").Resize(.Count, 12) = resArr
    End With
    eTime = Timer
    MsgBox "Code took " & eTime - sTime & " Sec to complete"
    OptimizeVBA False
End Sub

Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub

It returned same number of rows, but I didn't check the result in detail. I suggest you check the result in detail.

Edit: Noticed that I had missed replacing couple of "^" with constant defined (myDelim), updated code.

 

[Mange08]

Wow, that was blazingly fast solution.
I will double check everything, but sure looks good.

Many thanks for this.

 

[Chihiro]

FYI - If you have access to it, this type of operation is best done in PowerQuery. While it's a bit slower than VBA (Array + Dictionary method I did), it is more robust and much easier to update if some requirement changes down the line.