How to speed data copy from sheet1 to Other sheets by using Arrays, Excel vba?

Question

I have workbook with three sheets. I copy data from sheet1 to sheet2 & sheet3 depend on specific condition on sheet1, value = "Yes" on columns T or U. The below code works fine using for Loop, but it is slow. Now I transferred all data of sheet1 to array .

MyArray = Sheet1.Range("A3:U" & LastRow).Value2

is it possible to copy data from this array (by condition if specific value on it) to the other sheets . I am new to vba , so any help will be appreciated .

Sub Copy_Data_On_Condition()

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False

  Dim LastRow As Long
  Dim ris_column As Range
  Dim cell As Object
  Dim DestRng As Range
  Dim MyArray() As Variant  

LastRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Row

MyArray = Sheet1.Range("A3:U" & LastRow).Value2

Set ris_column = Sheet1.Range("T3:T" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
   Set DestRng = Sheet2.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
   cell.EntireRow.Copy DestRng
End If
Next cell

Set ris_column = Sheet1.Range("U3:U" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
   Set DestRng = Sheet3.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
   cell.EntireRow.Copy DestRng
End If
Next cell

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True

End Sub

Update: Both two answers works perfectly , I tested on a sheet with total 2180 rows and copied rows about 1200. "FaneDure" Code takes about 4 second to finish and "Super Symmetry" code takes 0.07 of second which is significantly faster .

Answer 1

If you don't want to consider autofilter option.

Option Explicit

Sub Copy_Data_On_Condition()
'_____________________________________________________________
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'_____________________________________________________________

Dim arr, findT As Range, findU As Range, arrStr As String, i As Long, j As Long
Dim LastRow As Long, ColT As Range, ColU As Range, k As Long, n As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row

k = 3000
For j = 2 To LastRow Step WorksheetFunction.Min(LastRow, k)
    '_____________________________________________________________
    'Evaluate Column T for "Yes" and create range findT
    
    Set ColT = Sheet1.Range("T" & j + 1 & ":T" & WorksheetFunction.Min(j + k, LastRow))
    arr = Evaluate("Transpose(IF((" & ColT.Address & "=" & """YES""" & ")," & _
            """A""" & "& ROW(" & ColT.Address & ") &" & _
            """:U""" & "& ROW(" & ColT.Address & "),""0""))")
    arrStr = Replace(Join(arr, ","), ",0", "")
    
    If Left(arrStr, 2) = "0," Then
        arrStr = Right(arrStr, Len(arrStr) - 2)
    End If
    
    For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
    arrStr = WorksheetFunction.Substitute(arrStr, ",", "|", n)
    Next n
    
    arr = Split(arrStr, "|")
    
    For n = 0 To UBound(arr)
        If findT Is Nothing Then
            'arr = Split(arrStr, "|")
            Set findT = Evaluate(arr(n))
            Else
            Set findT = Union(Evaluate(arr(n)), findT)
        End If
    Next n
    Debug.Print findT.Cells.Count
    '_____________________________________________________________
    'Evaluate Column U for "Yes" and create range findU
    Set ColU = Sheet1.Range("U" & j + 1 & ":U" & WorksheetFunction.Min(j + k, LastRow))
    arr = Evaluate("Transpose(IF((" & ColU.Address & "=" & """YES""" & ")," & _
            """A""" & "& ROW(" & ColU.Address & ") &" & _
            """:U""" & "& ROW(" & ColU.Address & "),""0""))")
    arrStr = Replace(Join(arr, ","), ",0", "")
    
    If Left(arrStr, 2) = "0," Then
        arrStr = Right(arrStr, Len(arrStr) - 2)
    End If
    For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
    arrStr = WorksheetFunction.Substitute(arrStr, ",", "|")
    Next n
    
    arr = Split(arrStr, "|")
    
    For n = 0 To UBound(arr)
        If findU Is Nothing Then
            'arr = Split(arrStr, "|")
            Set findU = Evaluate(arr(n))
            Else
            Set findU = Union(Evaluate(arr(n)), findU)
        End If
    Next n
    Debug.Print findU.Cells.Count
'_____________________________________________________________

Next j

findT.Copy Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Offset(1)
findU.Copy Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1)
'_____________________________________________________________


SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"

End Sub

Answer 2

Copy Filtered Data

• In this solution, it is assumed that you always want to start your resulting data in a given cell (dFirst) removing the previous contents.

Option Explicit

Sub CopyData()
    
    Const sFirst As String = "A3"
    
    Dim sCols As Variant: sCols = Array(20, 21)
    Dim sCriteria As Variant: sCriteria = Array("Yes", "Yes")
    Dim dFirst As Variant: dFirst = Array("A3", "A3")
    Dim AutoFitColumns As Variant: AutoFitColumns = Array(True, True)
    
    Dim sws As Worksheet: Set sws = Sheet1
    Dim dws As Variant: dws = Array(Sheet2, Sheet3)
    
    Dim srg As Range: Set srg = RefRange(sws.Range(sFirst))
    If srg Is Nothing Then Exit Sub
    
    Dim dData As Variant
    Dim n As Long
    
    For n = LBound(dws) To UBound(dws)
        dData = GetCriteriaRows(srg, sCriteria(n), sCols(n))
        If Not IsEmpty(dData) Then
            WriteData dData, dws(n).Range(dFirst(n)), AutoFitColumns(n)
        End If
    Next n

End Sub

' Creates a reference to the range from a given first cell (range)
' to the cell at the intersection of the last non-empty row
' and the last non-empty column.
Function RefRange( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1)
        Dim rg As Range
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1, _
            .Worksheet.Columns.Count - .Column + 1)
        Dim lCell As Range
        Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function
        Dim lRow As Long: lRow = lCell.Row
        Set lCell = rg.Find("*", , , , xlByColumns, xlPrevious)
        Set RefRange = .Resize(lRow - .Row + 1, lCell.Column - .Column + 1)
    End With
End Function

' Returns a 2D one-based array containing the rows with matching criteria
' in a given column.
Function GetCriteriaRows( _
    ByVal srg As Range, _
    ByVal CriteriaString As String, _
    Optional ByVal CriteriaColumn As Long = 1) _
As Variant
    
    If srg Is Nothing Then Exit Function
    If Len(CriteriaString) = 0 Then Exit Function
    If CriteriaColumn < 0 Then Exit Function
    
    Dim drCount As Long: drCount = Application.CountIf(srg, CriteriaString)
    If drCount = 0 Then Exit Function
    
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    If CriteriaColumn > cCount Then Exit Function
    
    Dim sData As Variant
    If srCount + cCount = 2 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim cValue As Variant
    Dim r As Long, c As Long, n As Long
    
    For r = 1 To srCount
        cValue = CStr(sData(r, CriteriaColumn))
        If cValue = CriteriaString Then
            n = n + 1
            For c = 1 To cCount
                dData(n, c) = sData(r, c)
            Next c
        End If
    Next r

    GetCriteriaRows = dData

End Function

' Writes the values from a 2D one-based array to a range.
Sub WriteData( _
        ByVal Data As Variant, _
        ByVal FirstCellRange As Range, _
        Optional ByVal AutoFitColumns As Boolean = False)
    
    If FirstCellRange Is Nothing Then Exit Sub
    If IsEmpty(Data) Then Exit Sub
    
    Dim srCount As Long: srCount = UBound(Data, 1)
    Dim scCount As Long: scCount = UBound(Data, 2)
    
    Dim DoesFit As Boolean
    Dim DoesNotFitExactly As Boolean
    
    With FirstCellRange.Cells(1)
        
        If .Worksheet.Columns.Count - .Column + 1 >= scCount Then
            Select Case .Worksheet.Rows.Count - .Row + 1
            Case srCount
                DoesFit = True
            Case Is > srCount
                DoesFit = True
                DoesNotFitExactly = True
            End Select
        End If
        
        If DoesFit Then
            Dim drg As Range: Set drg = .Resize(srCount, scCount)
            drg.Value = Data
            If DoesNotFitExactly Then
                drg.Resize(.Worksheet.Rows.Count - .Row - srCount + 1) _
                    .Offset(srCount).ClearContents
            End If
            If AutoFitColumns Then
                drg.EntireColumn.AutoFit
            End If
        End If
        
    End With

End Sub


' Returns a 2D one-based array containing the values of a range
' (Not used because it is incorporated in 'GetCriteriaRows').
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    Dim Data As Variant
    If rg.Rows.Count + rg.Columns.Count = 2 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
    Else
        Data = rg.Value
    End If
    GetRange = Data
End Function

Answer 3

Because a direct autofilter is not an option, processing the array in memory should give you the fastest result as it minimises the interaction of VBA with the excel application. I believe the following should make your code significantly faster:

Sub Copy_Data_On_Condition()
    Dim dStart As Double: dStart = Timer
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim srcData As Variant
    
    Dim sht2Data() As Variant
    Dim sht2Rows As Long
    Dim sht2CriteriaCol As Long: sht2CriteriaCol = 20 'T
    
    Dim sht3Data() As Variant
    Dim sht3Rows As Long
    Dim sht3CriteriaCol As Long: sht3CriteriaCol = 21 'U
    
    Dim outputCols As Long
    Dim i As Long, j As Long
    
    With Sheet1
        srcData = .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    End With
    outputCols = UBound(srcData, 2)
    
    For i = LBound(srcData) To UBound(srcData)
        If srcData(i, sht2CriteriaCol) = "Yes" Then
            sht2Rows = sht2Rows + 1
            ReDim Preserve sht2Data(1 To outputCols, 1 To sht2Rows)
            For j = 1 To outputCols
                sht2Data(j, sht2Rows) = srcData(i, j)
            Next j
        End If
    
        If srcData(i, sht3CriteriaCol) = "Yes" Then
            sht3Rows = sht3Rows + 1
            ReDim Preserve sht3Data(1 To outputCols, 1 To sht3Rows)
            For j = 1 To outputCols
                sht3Data(j, sht3Rows) = srcData(i, j)
            Next j
        End If
    Next i
    
    If sht2Rows > 0 Then
        Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht2Rows, outputCols).Value = WorksheetFunction.Transpose(sht2Data)
    End If
        
    If sht3Rows > 0 Then
        Sheet3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht3Rows, outputCols).Value = WorksheetFunction.Transpose(sht3Data)
    End If
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Time taken: " & Format(Timer - dStart, "0.000s")
End Sub

Another fast option is to add a dummy sheet (if possible), use autofilter then delete the dummy worksheet. This is very fast and the code is very simple:

Sub Copy_Data_On_Condition2()
    Dim dStart As Double: dStart = Timer
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
            
    Sheet1.Copy After:=Sheet1
    With ActiveSheet
        With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
            .Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
            .Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            
            .Rows(1).Offset(-1, 0).AutoFilter Field:=20
            .Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
            .Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            
            .AutoFilter
        End With
        .Delete
    End With
    
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox Format(Timer - dStart, "0.000")
End Sub

Edit: (following comment and file share)

Your worksheet is protected but without password. Therefore, you can actually do autfilter in place without having to add a new dummy sheet. Your autfilter becomes:

Sub Copy_Data_On_Condition2()
    Dim dStart As Double: dStart = Timer
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Check first if there's autfilter
    If Sheet1.AutoFilterMode Then Sheet1.AutoFilter.ShowAllData
    
    With Sheet2
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        .Rows("4:" & .Rows.Count).ClearContents
    End With
    
    With Sheet3
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        .Rows("4:" & .Rows.Count).ClearContents
    End With
    
'=========== Super Symmetry Code _ Auto Filter
            
    With Sheet1
        .Unprotect
        With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
            .Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
            .Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            
            .Rows(1).Offset(-1, 0).AutoFilter Field:=20
            .Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
            .Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        End With
        .Protect
    End With
    
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox Format(Timer - dStart, "0.000")
End Sub

Autofilter is your best friend here if and when your data grows.

Answer 4

Please, try the next code:

Sub Copy_Data_On_Condition()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, LastRow As Long
  Dim arr_column, rngT As Range, rngU As Range, i As Long, lastCol As Long

 Set sh1 = Sheet1: Set sh2 = Sheet2: Set sh3 = Sheet3 'only to make the code more compact
 
 LastRow = sh1.cells(rows.count, 1).End(xlUp).row    'last row in A:A column
 lastCol = sh1.UsedRange.Columns.count               'last column of Sheet1, to avoid copying the whole row

 arr_column = sh1.Range("T3:U" & LastRow).Value2     'put in an array the columns to be processed against "Yes" string                                                                     
                                                     'process both columns in the same iteration to make code faster
 For i = 1 To UBound(arr_column)                     'iterate between the array rows and process the columns values
     If arr_column(i, 1) = "Yes" Then                'finding a match in column T:T:
        If rngT Is Nothing Then                      'if the rngT keeping the range to be copied is not Set (yet)
            Set rngT = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
        Else
            Set rngT = Union(rngT, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
        End If
    End If
    If arr_column(i, 2) = "Yes" Then                   'finding a match in column U:U:
        If rngU Is Nothing Then                        'if the rngU keeping the range to be copied is not Set (yet)
            Set rngU = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
        Else
            Set rngU = Union(rngU, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
        End If
    End If
 Next i
 If Not rngT Is Nothing Then 'if rngT has been set (it contains at least a row), copy it in Sheet2
    rngT.Copy Destination:=sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1) 'copy the range at once
 End If

 If Not rngU Is Nothing Then 'if rngU has been set (it contains at least a row), copy it in Sheet3
    rngU.Copy Destination:=sh3.Range("A" & sh3.rows.count).End(xlUp).Offset(1) 'copy the range at once
 End If
End Sub