+ Reply to Thread
Results 1 to 9 of 9

Long code takes an age to run

Hybrid View

  1. 08-25-2009, 06:30 AM #1
    E3iron
    E3iron is offline
    Registered User
    Join Date
    07-20-2009
    Location
    London
    MS-Off Ver
    Excel 2003
    Posts
    63

    Talking Long code takes an age to run

    Hi

    I have the following code: Which when its run it looks in AC for a value i.e RDA Uk and when it finds it it copies the row and then pastes in "UK". It will continue until it finds "", then it will move on to the next value and do the same again. I have 6/7 values to find and move to another sheet.

    Can anyone help edit to code to help the macro to run quicker?

    Sub CountryLoop()
'Uk
Sheets("Combined").Select
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA UK" Then
ActiveCell.EntireRow.Copy
Sheets("UK").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("UK").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'Benelux
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA Benelux" Then
ActiveCell.EntireRow.Copy
Sheets("Bene").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("Bene").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'iberia
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA Iberia" Then
ActiveCell.EntireRow.Copy
Sheets("IBE").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("IBE").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'Germany
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA Germany" Then
ActiveCell.EntireRow.Copy
Sheets("GER").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("GER").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'France
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA France" Then
ActiveCell.EntireRow.Copy
Sheets("FRA").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("FRA").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'Finland
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA Finland" Then
ActiveCell.EntireRow.Copy
Sheets("FIN").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("FIN").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'Romania
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA Romaina" Then
ActiveCell.EntireRow.Copy
Sheets("CE").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("CE").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select

Sheets("Combined").Select
'CE Region
[AC1].Select
Do Until ActiveCell = ""
If ActiveCell = "RDA CE Region" Then
ActiveCell.EntireRow.Copy
Sheets("CE").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

ActiveSheet.Paste
Sheets("Combined").Select
Else
    End If
ActiveCell.Offset(1, 0).Select
Loop
[a1].Select

Sheets("CE").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select



'
End Sub
    Reply With QuoteRegister To Reply
  2. 08-25-2009, 06:47 AM #2
    royUK
    royUK is offline
    Forum Expert royUK's Avatar
    Join Date
    11-18-2003
    Location
    Derbyshire,UK
    MS-Off Ver
    Xp; 2007; 2010
    Posts
    26,200

    Re: Long code takes an age to run

    One of the main problems is that you are selecting ranges, this is not necessary.
    You are alos using a loop to find the next blank cell, again time consuming.
    You are using a loop to copy individual rows, it would be more efficient to copy a block of rows.

    Attach an example workbook
    Hope that helps.

    RoyUK
    --------
    For Excel Tips & Solutions, free examples and tutorials why not check out my web site

    Free DataBaseForm example
    Reply With QuoteRegister To Reply
  3. 08-25-2009, 07:06 AM #3
    E3iron
    E3iron is offline
    Registered User
    Join Date
    07-20-2009
    Location
    London
    MS-Off Ver
    Excel 2003
    Posts
    63

    Re: Long code takes an age to run

    Getting a error when i'm trying to up load, i will try again soon
    Reply With QuoteRegister To Reply
  4. 08-25-2009, 08:06 AM #4
    royUK
    royUK is offline
    Forum Expert royUK's Avatar
    Join Date
    11-18-2003
    Location
    Derbyshire,UK
    MS-Off Ver
    Xp; 2007; 2010
    Posts
    26,200

    Re: Long code takes an age to run

    The file may be to big, try zipping it
    Reply With QuoteRegister To Reply
  5. 08-25-2009, 08:49 AM #5
    E3iron
    E3iron is offline
    Registered User
    Join Date
    07-20-2009
    Location
    London
    MS-Off Ver
    Excel 2003
    Posts
    63

    Re: Long code takes an age to run

    I get the following:
    Database error
    The Excel Help Forum database has encountered a problem.

    --------------------------------------------------------------------------------

    Please try the following:
    Load the page again by clicking the Refresh button in your web browser.
    Open the www.excelforum.com home page, then try to open another page.
    Click the Back button to try another link.

    The www.excelforum.com forum technical staff have been notified of the error, though you may contact them if the problem persists.

    We apologise for any inconvenience
    Reply With QuoteRegister To Reply
  6. 10-05-2009, 05:04 AM #6
    E3iron
    E3iron is offline
    Registered User
    Join Date
    07-20-2009
    Location
    London
    MS-Off Ver
    Excel 2003
    Posts
    63

    Re: Long code takes an age to run

    Please find sample work book attached
    Attached Files Attached Files
    Reply With QuoteRegister To Reply
  7. 10-05-2009, 07:15 AM #7
    DonkeyOte
    DonkeyOte is offline
    Forum Guru DonkeyOte's Avatar
    Join Date
    10-22-2008
    Location
    Northumberland, UK
    MS-Off Ver
    O365
    Posts
    21,531

    Re: Long code takes an age to run

    Based on your file perhaps try something along the lines of the below, note however I created a sheet ROM for Romania data as this was not present originally.

    Public Sub CountryLoop()
Dim wsCombined As Worksheet
Dim vRegions As Variant, vSheets As Variant, vStart As Variant, vEnd As Variant
Dim lngRegion As Long
Dim xlCalc As XlCalculation
On Error GoTo ExitPoint
With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set wsCombined = Sheets("Combined")
vRegions = Array("RDA Benelux", "RDA CE Region", "RDA Finland", "RDA France", "RDA Germany", "RDA Iberia", "RDA Romania", "RDA UK")
vSheets = Array("BENE", "CE", "FIN", "FRA", "GER", "IBE", "ROM", "UK")
For lngRegion = LBound(vRegions) To UBound(vRegions) Step 1
    vStart = Application.Match(vRegions(lngRegion), wsCombined.Columns(29), 0)
    If IsNumeric(vStart) Then
        vEnd = vStart + Application.CountIf(wsCombined.Columns(29), vRegions(lngRegion)) - 1
        With wsCombined
            .Range(.Cells(vStart, "A"), .Cells(vEnd, "BS")).Copy Sheets(vSheets(lngRegion)).Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
    vStart = 0
    vEnd = vStart
Next lngRegion
ExitPoint:
Set wsCombined = Nothing
With Application
    .Calculation = xlCalc
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub
    My Recommended Reading:

    Volatility
    Sumproduct & Arrays
    Pivot Intro
    Email from XL - VBA & Outlook VBA
    Function Dictionary & Function Translations
    Dynamic Named Ranges
    Reply With QuoteRegister To Reply
  8. 10-05-2009, 07:27 AM #8
    E3iron
    E3iron is offline
    Registered User
    Join Date
    07-20-2009
    Location
    London
    MS-Off Ver
    Excel 2003
    Posts
    63

    Re: Long code takes an age to run

    Thanks very much for your help.

    The reason there is no Romaina is because it goes in with the CE Region. Also this code works for all apart from UK.
    Reply With QuoteRegister To Reply
+ Reply to Thread
« Previous Thread | Next Thread »

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Forum Rules


Search Engine Friendly URLs by vBSEO 3.6.0 RC 1