1

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 .

Improve this question
7
  • 1
    Copying the entire row is not the fastest way of copying. Then, Excel consumes resources and slow down the code if you paste each row. The arrays method is not suitable when you try copying the whole row. You can use an array only to make iteration faster. In you described case, I think, the best solution would be to create a Union range and paste it at once at the end of the code. Commented Jul 4, 2021 at 14:01
  • You can not use filter on both the columns at once as you are looking for yes on T .. OR .. U columns. I would suggest you capture range of the filtered rows twice once for Colum T and the for Column U. And the make union of those filtered ranges. and then you can just copy those ranges... NO Need to loop though each cell. .. You can refer this question to capture filtered range. Commented Jul 4, 2021 at 14:14
  • @Naresh.This workbook is protected and shared on the same time , So unfortunately autofilter copy is not applicable Commented Jul 4, 2021 at 14:34
  • @Naresh. I'm out of work , so I do not test your code yet , I don't know why you removed it . Commented Jul 4, 2021 at 16:20
  • @Waleed_wwm .. Union method in FaneDuru's answer works better than array. As we can not add rows to an array without transpose and there will be limitation on number of rows. With union you can add many rows. Commented Jul 4, 2021 at 16:32

4 Answers 4

Reset to default
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
Improve this answer
Sign up to request clarification or add additional context in comments.

2 Comments

@Waleed_wwm May I know why you changed your mind regarding the above code? I do not care to much about notoriety, but I would like to understand why. Is is something else to be done with the code and I missed it? Is it other piece of code working faster?
I really appreciate your efforts , your code has no probem , other code by "Super." Is fine also but it is faster ( first concern) . also after I test remaining answers , I will update results
1

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.

Improve this answer

4 Comments

your array code is significantly faster , but data on sheet2 is not complete which depends on column T , attached is the sample file easyupload.io/zcp3n9
Although autofilter is functional in visual excel , it gives error in vba
Apologies: the line Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht3Rows, outputCols).Value = .... should really be Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht2Rows, outputCols).Value = .... note: Resize(sht3Rows, outputCols) should be Resize(sht2Rows, outputCols)
Symmety , because it is a sample file I forgot to set password , but unfortunately the actual file has password. I think i should post another question for autofilter issue in vba. Anyway ,many great thanks " Super Symmetry" for all your help 👏👏
0

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
Improve this answer

4 Comments

your code works but it unhide columns in sheets 2 & 3, also please if I need to adapt for other sheets or columns , do I just change two lines which contains arrary or not ? This the sample file easyupload.io/zcp3n9
To not unhide columns, do not use AutoFit i.e. AutoFitColumns = Array(False, False). Also, change to dFirst = Array("A4", "A4") which refers to the first 'data' cells of the destination worksheets. All those ... = Array(First Element, Second Element) lines need to have the same number of elements. In the example code, they contain two elements each. If you want to add another, just add a comma and another appropriate value for all five cases (lines).
and unfortunately , it is unstable if workbook is shared. First run run quickly 0.12 second and next takes 30 seconds or hang
Sorry, I'm not familiar with sharing workbooks, but on my end, it works fine (a split second) in your workbook or mine.
0

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
Improve this answer

2 Comments

@Waleed_wwm No need to be sorry .. I know autofilter works great as mentioned in the comments on the qquestion. But this answer is a totally different approach.. It evaluates 3000 rows at a time and with Evaluate function and then makes union of valid ranges. In absence of autofilter(which was your requirement earlier), this should work faster... I guess. :)
"Naresh" , it works but takes the same time as "FaneDure" code about 4.2 seconds with copy of 1000 rows , anyway thanks for your efforts

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.