copying rows if row contain specific value & Macro is taking more time to run

[srikanth sare]

Hi
The macro is working fine but it takes more time to run the code
help me in solving the issue

Private Sub ASALES()
    On Error GoTo EH
    Application.Run "TurnOff"
    
    Sheet5.Unprotect "1818"
    Sheet5.Cells.Copy
    Sheet8.[a1].PasteSpecial 13
    Application.CutCopyMode = False
    Sheet9.Range("A6:EB9999").Clear
    
    Dim xRg As Range
    Dim lastrow As Variant
    Dim I, J As Long
    I = Sheet8.UsedRange.Rows.Count
    J = 6
    Set xRg = Union(Sheet8.Range("BW6:BW" & I), Sheet8.Range("BY6:BY" & I), Sheet8.Range("CA6:CA" & I), Sheet8.Range("CC6:CC" & I), Sheet8.Range("CE6:CE" & I), Sheet8.Range("CG6:CG" & I), _
                    Sheet8.Range("CI6:CI" & I), Sheet8.Range("CK6:CK" & I), Sheet8.Range("CM6:CM" & I), Sheet8.Range("CO6:CO" & I), Sheet8.Range("CQ6:CQ" & I), Sheet8.Range("CS6:CS" & I), _
                    Sheet8.Range("CU6:CU" & I), Sheet8.Range("CW6:CW" & I), Sheet8.Range("CY6:CY" & I), Sheet8.Range("DA6:DA" & I))
                    
    For Each KCELL In xRg
    If KCELL.Value = Sheet5.Range("K1").Value Then
            KCELL.EntireRow.Copy
            Sheet9.Range("A" & J).PasteSpecial xlPasteValues
            Sheet9.Range("A" & J).PasteSpecial xlPasteFormats
            J = J + 1
    End If
    Next
    
    With Sheet9
    lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
    Set rng = .Range("A5:EB" & lastrow)
    rng.RemoveDuplicates Columns:=3, Header:=xlYes
    rng.Sort key1:=Sheet9.Range("C5"), order1:=xlAscending, Header:=xlYes
    End With
    Sheet8.Cells.Clear
CleanUp:     On Error Resume Next
         Application.Run "TurnOn"
   Sheet5.Protect "1818", DrawingObjects:=False, Contents:=True, Scenarios:=False, UserInterFaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
   Exit Sub
EH: Debug.Print Err.Description  ' Do error handling
   MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!"
   Resume CleanUp
End Sub

 

[GWteB]

It's kind of hard to figure out exactly what your ultimate goal is, but I think I've got a small improvement for you. It is therefore not as efficient as it could be, but might be worth a try.
This part ....

    For Each KCELL In xRg
    If KCELL.Value = Sheet5.Range("K1").Value Then
            KCELL.EntireRow.Copy
            Sheet9.Range("A" & J).PasteSpecial xlPasteValues
            Sheet9.Range("A" & J).PasteSpecial xlPasteFormats
            J = J + 1
    End If
    Next

could be replaced by the code below

    Dim n As Long
    Dim MyValue As Variant
    MyValue = Sheet5.Range("K1").Value
    
    For n = 1 To xRg.Rows.Count
        For Each KCELL In Intersect(xRg, xRg.Rows(n).EntireRow)
            If KCELL.Value = MyValue Then
                KCELL.EntireRow.Copy
                Sheet9.Range("A" & J).PasteSpecial xlPasteValues
                Sheet9.Range("A" & J).PasteSpecial xlPasteFormats
                J = J + 1
                Exit For
            End If
        Next
    Next n

 

[srikanth sare]

Yes the code has shown the Improvement and efficient
In the below image myvalue = ASK 002 which may repeated multiple times in a row

Can we do it like this instead of copying the entire row one by one, first we have to find all the rows which meet criteria and create an array and then copy-paste with or without using a helper column

With Sheet9
    lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
    Set rng = .Range("A5:EB" & lastrow)
    rng.RemoveDuplicates Columns:=3, Header:=xlYes
    rng.Sort key1:=Sheet9.Range("C5"), order1:=xlAscending, Header:=xlYes
 End With

The above code is used to remove duplicates and sort in order if we do it with helper column then above code may not be used and reduces times as data is already sorted in order.

 

[GWteB]

Can we do it like this instead of copying the entire row one by one, first we have to find all the rows which meet criteria and create an array and then copy-paste with or without using a helper column

I agree that using an Array memory type is many times faster than repetitive access to the worksheet. Since we are examining a range of non-contiguous columns, using an Array (as a memory type) is not useful because we still need to repetitively access the worksheet to fill the Array. The copy paste process, on the other hand, can take place in a single pass. I made some amendments to make that happen.

The above code is used to remove duplicates and sort in order if we do it with helper column then above code may not be used and reduces times as data is already sorted in order.

I do not understand in what way a helper column could provide more efficiency in both removing duplicates and sorting, based on the contents in column "C:C".

In relation to your post #1 code, replace the code snippet directly below with the second one. Hopefully this suits your requirements.

    For Each KCELL In xRg
    If KCELL.Value = Sheet5.Range("K1").Value Then
            KCELL.EntireRow.Copy
            Sheet9.Range("A" & J).PasteSpecial xlPasteValues
            Sheet9.Range("A" & J).PasteSpecial xlPasteFormats
            J = J + 1
    End If
    Next

replacement:

    Dim n           As Long
    Dim MyValue     As Variant
    Dim raSource    As Range

    MyValue = Sheet5.Range("K1").Value
    For n = 1 To xRg.Rows.Count
        For Each KCELL In Intersect(xRg, xRg.Rows(n).EntireRow)
            If KCELL.Value = MyValue Then
                If raSource Is Nothing Then
                    Set raSource = KCELL.EntireRow
                Else
                    Set raSource = Union(raSource, KCELL.EntireRow)
                End If
                Exit For
            End If
        Next
    Next n
    
    raSource.Copy
    Sheet9.Range("A6").PasteSpecial xlPasteValues
    Sheet9.Range("A6").PasteSpecial xlPasteFormats
    Application.CutCopyMode = False

 

[srikanth sare]

That's Amazingly Fast and efficient compared to my earlier code.
Thank You

GWteB​

 

[GWteB]

You are welcome and thanks for letting me know.

 

[srikanth sare]

Hi GWteB

In the Below code Instead of entire row can we have a range like Range(Cells(n,1),cells(n,132)) or Range("A"&n : "EB"&n)

    Dim n           As Long
    Dim MyValue     As Variant
    Dim raSource    As Range

    MyValue = Sheet5.Range("K1").Value
    For n = 1 To xRg.Rows.Count
        For Each KCELL In Intersect(xRg, xRg.Rows(n).EntireRow)
            If KCELL.Value = MyValue Then
                If raSource Is Nothing Then
                    Set raSource = KCELL.EntireRow
                Else
                    Set raSource = Union(raSource, KCELL.EntireRow)
                End If
                Exit For
            End If
        Next
    Next n
   
    raSource.Copy
    Sheet9.Range("A6").PasteSpecial xlPasteValues
    Sheet9.Range("A6").PasteSpecial xlPasteFormats
    Application.CutCopyMode = False

 

[GWteB]

In the Below code Instead of entire row can we have a range like Range(Cells(n,1),cells(n,132)) or Range("A"&n : "EB"&n)

The code you marked as a solution checks for just one match per row. If this is the case, that particular row (within those non-contiguous areas) is marked for copying (and therefore other potential matches on that row are skipped) and the next row is examined.
So it depends on what you want to achieve whether your proposed change is usefull or not. You really need to be more specific.