Speeding up a code that cuts and pastes multiple non-contiguous ranges to an external workbook

How do I make this code faster and more elegant?

Thanks,
John
Sub MakeExceptions()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim cel As Range
For Each cel In Range("AC6:AC756")
  If cel = 1 Then
    cel.EntireRow.Cut
    Windows("Exceptions.xls").Activate
        Dim pastePt As Range
        Set pastePt = [TopA].End(xlDown).Offset(1, 0)
    pastePt.Select
    ActiveSheet.Paste
  Else
  End If
  ThisWorkbook.Activate
Next
Application.CutCopyMode = False
'Call DeleteExceptions
Application.ScreenUpdating = True
End Sub

Open in new window

LVL 1
John CarneyReliability Business Tools Analyst IIAsked:
Who is Participating?
 
byundtConnect With a Mentor Commented:
John,
I suggest moving the Window activate statement outside of the loop. You only need to reference it once to set your pointer.
Sub MakeExceptions()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim cel As Range, pastePt As Range
Dim i As Long
Windows("Exceptions.xls").Activate
Set pastePt = [TopA].End(xlDown)
ThisWorkbook.Activate

For Each cel In Range("AC6:AC756")
  If cel = 1 Then
    i = i + 1
    cel.EntireRow.Cut pastePt.Offset(i, 0)
  End If
Next
Application.CutCopyMode = False
'Call DeleteExceptions
Application.ScreenUpdating = True
End Sub

Open in new window

Brad
0
 
Saqib Husain, SyedEngineerCommented:
See if this routine helps

Sub MakeExceptions()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim cel As Range
dim str as string
For Each cel In Range("AC6:AC756")
  If cel = 1 Then
    cstr=cstr & cel.row & ":" & cel.row
    Windows("Exceptions.xls").Activate
  Else
  End If
  ThisWorkbook.Activate
Next
    cstr=right(cstr ,len(cstr)-1)
      range(cstr).select
        Dim pastePt As Range
        Set pastePt = [TopA].End(xlDown).Offset(1, 0)
    pastePt.Select
    ActiveSheet.Paste

Application.CutCopyMode = False
'Call DeleteExceptions
Application.ScreenUpdating = True
End Sub
0
 
Jorge PaulinoIT Pro/DeveloperCommented:
If you have code that run on events, you can also turn it off, using Application.EnableEvents = False

You could also skip the selection (pastePt.Select) using just "ActiveSheet.Paste pastePt"
0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

 
Saqib Husain, SyedEngineerCommented:
Also move

ThisWorkbook.Activate

to below the "Next"
0
 
John CarneyReliability Business Tools Analyst IIAuthor Commented:
Hi ssaquib, thanks. I get a syntax error on all the lines beginning with cstr. Do I need to define it as a variable?
0
 
Saqib Husain, SyedEngineerCommented:
Sorry, I did try to define but made a mistake.

Change dim str.... to dim cstr...
0
 
FernandoFernandesCommented:
i have another idea which will make your code so fast that you won't even have time to breath twice before it ends...

Just one quick question, can the code sort your table by the column AC ? (this will make it even faster)

p.s: I am already working on a new code, regardless of your answer :)
0
 
FernandoFernandesConnect With a Mentor Commented:
ok, no need to sort...
use the code below:

 
Option Explicit

Sub MakeExceptions()
Dim oCells      As Range
Dim pastePt     As Range
Dim arrAllCells As Variant
Dim lCounter    As Long

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    arrAllCells = Range("AC6:AC756")
    If VBA.IsArray(arrAllCells) Then
        For lCounter = LBound(arrAllCells) To UBound(arrAllCells)
            If arrAllCells(lCounter, 1) = 1 Then
                If oCells Is Nothing Then
                    Set oCells = ActiveSheet.Cells(lCounter + 5, 1).EntireRow
                Else
                    Set oCells = Application.Union(oCells, ActiveSheet.Cells(lCounter + 5, 1).EntireRow)
                End If
            End If
        Next
    End If
    If Not oCells Is Nothing Then
        oCells.Copy
        Windows("Exceptions.xls").Activate
        Set pastePt = [TopA].End(xlDown).Offset(1, 0)
        pastePt.PasteSpecial Paste:=xlPasteAll
        oCells.Delete Shift:=xlUp
    End If
    
    With Application
        .Calculation = xlCalculationAutomatic
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Open in new window

0
 
John CarneyReliability Business Tools Analyst IIAuthor Commented:
Looks like one or both of the last two answers lwill work. I'm anxious to try them but I won't be able to test them out til Monday when I get to work.

Thanks,
John
0
 
John CarneyReliability Business Tools Analyst IIAuthor Commented:
"Dim cstr as String..." I should have noticed that. :-) Fernando and Brad, yours look promising, I hope I actually do manage to check this out tomorrow. As I've been asking several other people tonight, pls forgive me for losing track of this question!

Thanks,
John
0
 
John CarneyReliability Business Tools Analyst IIAuthor Commented:
Man, where have I been! Brad and Fernando, yours both work faster than mine, thank you. Fernando, although it wasn't critical yours produced a REF error for some reason on one of the copied columns, which is why I gave Brad the extra points.

Ssaqibh, I tinkered with yours a lot but I just couldn't get it to work. Probably my ineptitude, sorry.\\Thanks,
John
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.