Solved

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

Posted on 2011-03-25
12
224 Views
Last Modified: 2012-08-13
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

0
Comment
Question by:gabrielPennyback
  • 4
  • 3
  • 2
  • +2
12 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 35219620
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
 
LVL 48

Expert Comment

by:jpaulino
ID: 35219622
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
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 35219634
Also move

ThisWorkbook.Activate

to below the "Next"
0
 
LVL 1

Author Comment

by:gabrielPennyback
ID: 35219695
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
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 35219700
Sorry, I did try to define but made a mistake.

Change dim str.... to dim cstr...
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 6

Expert Comment

by:FernandoFernandes
ID: 35219892
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
 
LVL 6

Assisted Solution

by:FernandoFernandes
FernandoFernandes earned 200 total points
ID: 35219946
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
 
LVL 81

Accepted Solution

by:
byundt earned 300 total points
ID: 35219959
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
 
LVL 1

Author Comment

by:gabrielPennyback
ID: 35303511
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
 
LVL 1

Author Comment

by:gabrielPennyback
ID: 35774870
"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
 
LVL 1

Author Closing Comment

by:gabrielPennyback
ID: 36142774
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

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

910 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now