Solved

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

Posted on 2011-03-25
12
227 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

 
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
 
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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Excel 2016 lost MRU list 8 70
Tricky shapes formula part 2 4 21
Excel Total at footer of invoice 5 22
Array not populating all cells in Excel 6 22
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

726 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