minimize run time for macro

[Lenna]

I have an operation that takes too long. Please suggest how to make it run faster.

Option Compare Text


Sub Takes2Long()


Application.ScreenUpdating = False


Dim cel As Range, rng As Range, lr As Long
Dim cel1 As Range, rng1 As Range, lr1 As Long
'deletecellsunderneath
lr = Worksheets("Sheet1 (2)").Cells(Rows.Count, "Q").End(xlUp).Row
Set rng = Worksheets("Sheet1 (2)").Range("Q2:Q" & lr) 'assumes a header row
    For Each cel In rng
        If InStr(cel.Value, "donor") > 0 Or InStr(cel.Value, "transplant") > 0 Then
          lr2 = Worksheets("DSA").Cells(Rows.Count, "Q").End(xlUp).Row 'sheet being pasted to, change if needed
           cel.Offset(1, 0).EntireRow.Cut Destination:=Worksheets("DSA").Range("A" & lr2 + 1)
        End If
   Next cel
  'cutdonorandtrasnplant
   lr1 = Worksheets("Sheet1 (2)").Cells(Rows.Count, "Q").End(xlUp).Row
Set rng1 = Worksheets("Sheet1 (2)").Range("Q2:Q" & lr1) 'assumes a header row
    For Each cel1 In rng1
        If InStr(cel1.Value, "donor") > 0 Or InStr(cel1.Value, "transplant") > 0 Then
           lr3 = Worksheets("DSA").Cells(Rows.Count, "Q").End(xlUp).Row 'sheet being pasted to, change if needed
           cel1.Offset(0, 0).EntireRow.Cut Destination:=Worksheets("DSA").Range("A" & lr3 + 1)
        End If
   Next cel1
  
 Application.ScreenUpdating = True


 End Sub

Thanks,

Lenna

 

[Lenna]

I'm cutting and pasting all rows underneath a row that contains "donor" or "transplant" in column Q. The second part of the macro cuts and pastes all rows that contain "donor" and "transplant". I'm sure the two loops can be combined but I'm not sure how.

I need to remove a row underneath first and a row that contains second.

Thanks,

Lenna

 

[wigi]

Hello

Why don't you cut 2 areas at once? This will change the order of the rows, though.

Option Compare Text

Sub Takes2Long()

    Dim cel As Range, lr As Long, lr2 As Long
    
    Application.ScreenUpdating = False
    
    'deletecellsunderneath
    lr2 = Worksheets("DSA").Cells(Rows.Count, "Q").End(xlUp).Row
    lr = Worksheets("Sheet1 (2)").Cells(Rows.Count, "Q").End(xlUp).Row
    For Each cel In Worksheets("Sheet1 (2)").Range("Q2:Q" & lr)
        If InStr(cel.Value, "donor") > 0 Or InStr(cel.Value, "transplant") > 0 Then
            cel.Offset(1).Resize(2).EntireRow.Cut Destination:=Worksheets("DSA").Range("A" & lr2 + 1)
            lr2 = lr2 + 2
        End If
    Next

    Application.ScreenUpdating = True

End Sub

Do not cut entire rows, limit to the number of columns needed:

cel.Offset(1).Resize(2).EntireRow.Cut

could become for example:

cel.Offset(1, 1 - cel.Column).Resize(2,26).Cut

if you need to cut columns A to Z (which is 26 columns starting in column A).

 

[wigi]

Without changing the order of pasting:

Option Compare Text

Sub Takes2Long()


    Dim cel As Range, lr As Long, lr2 As Long
    
    Application.ScreenUpdating = False
    
    lr2 = Worksheets("DSA").Cells(Rows.Count, "Q").End(xlUp).Row
    lr = Worksheets("Sheet1 (2)").Cells(Rows.Count, "Q").End(xlUp).Row
    For Each cel In Worksheets("Sheet1 (2)").Range("Q2:Q" & lr)
        If InStr(cel.Value, "donor") > 0 Or InStr(cel.Value, "transplant") > 0 Then
            cel.Offset(1).EntireRow.Cut Destination:=Worksheets("DSA").Range("A" & lr2 + 1)
            cel.EntireRow.Cut Destination:=Worksheets("DSA").Range("A" & lr2 + 2)
            lr2 = lr2 + 2
        End If
    Next


    Application.ScreenUpdating = True


End Sub

 

[Lenna]

Thank you