Very long macro - Thanks

Hi All

I used excel for year but only to do the simple things. I'm now getting into macro's, i have this macro that works but it takes an age to run and the screen flickering does my head in.
I have a sheet call Bene, which in col BO with have CAT , A,B,C,D,E,F,G or H. It will then move all the A to Bene Cat A.

I have only put this one on as an example but i have the same thing for UK,IBE,FRA,FIN
and all have 8 sheets to go with them. I have used the same code for all macros and i've even done a macro that does them all together using the same code.

Can someone please help me in making my macro more efficent

Sub BENECAT()
 'BENE
'CAT A
Sheets("BENE").Select
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT A" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT A").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT A").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'CAT B
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT B" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT B").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT B").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'BENE CAT C
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT C" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT C").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT C").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'BENE CAT D
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT D" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT D").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT D").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'BENE CAT E
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT E" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT E").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT E").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'BENE CAT F
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT F" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT F").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT F").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets("BENE").Select
'BENE CAT G
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT G" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT G").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT G").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
Sheets("BENE").Select
'BENE CAT H
[BO2].Select
Do Until ActiveCell = ""
If ActiveCell = "CAT H" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT H").Select
[A65536].Select
Selection.End(xlUp).Select
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select

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

Sheets("BENE CAT H").Select
Cells.Columns.AutoFit
Cells.Rows.AutoFit
ActiveCell.Select
  Cells.Select
    Range("AL1").Activate
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
  Sheets("control").Select
 End Sub

Hi,

You'd be better advised to upload the workbook and some notes as to exactly what sheets you are wanting to use and what you're trying to achieve as output.

It certainly looks as though the code could be simplified immensely. It may not even be necessary to use a loop to progress through cells in turn, a filtering function may be more appropriate. However even if a loop is required cutting out all the .Select and .Activate instructions, which I suspect are not needed, will speed up the code as well as switching off screen updating with Application.ScreenUpdating = False and probably temporarily putting the sheet(s) into manual calculation mode.

Regards

Hi,

As I thought this could be simplified to a few lines of code using a filter rather than looping through cells.

First name your data range on the BENE sheet with the name 'Data' defined as:

=OFFSET(BENE!$A$1,0,0,COUNTA(BENE!A:A),71)

Now use the following macro.

Sub SplitSheets()
    Dim x As Integer

    For x = 1 To Worksheets.Count
        If Sheets(x).Name <> "BENE" Then
            Range("Data").AutoFilter Field:=67, Criteria1:=Right(Sheets(x).Name, 5)
            Range("Data").Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(x).Range("A2")
            Sheet4.ShowAllData
        End If
    Next x
End Sub

HTH

The number one tip I learned form this forum:
Dont use ".Select". Change all the ".Select" to ".Activate"

As an example: from your macro in the first post

 
Sheets("BENE").Activate
[BO2].Activate
Do Until ActiveCell = ""
If ActiveCell = "CAT A" Then
ActiveCell.EntireRow.Copy
Sheets("BENE CAT A").Activate
[A65536].Activate
Selection.End(xlUp).Activate
If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Activate

I tried running your macro but could not get past:

    Selection.Sort Key1:=Range("AU2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

It generates an error on Excel 2k.

This the macro I would use, a slight tweak to Richard's:

Option Explicit                                 'turn on code checking

Sub SplitSheets()
Dim LR As Long, x As Long                       'declare all variables
Application.ScreenUpdating = False              'no screen flickering
Sheets("BENE").Activate                         'start on the correct sheet
LR = Range("A" & Rows.Count).End(xlUp).Row      'find the last row with data

    For x = 1 To Worksheets.Count               'go thru each existing worksheet one at a time
        If Sheets(x).Name <> "BENE" Then        'make sure it's not the data sheet
            Sheets(x).Cells.Clear               'clear existing report on that sheet
                                                'Filter column BO by the sheetname
            Range("BO:BO").AutoFilter Field:=1, Criteria1:=Right(Sheets(x).Name, 5)
                                                'Copy only visible data to sheet
            Range("A1:BR" & LR).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(x).Range("A1")
            Sheets(x).Columns.AutoFit           'adjust the appearance of the newly pasted data
        End If
    Next x                                      'next sheet
    
ActiveSheet.AutoFilterMode = False              'turn off the filter
Application.ScreenUpdating = True
End Sub

Comments added above into original macro.

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED].


(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated. It is found across from the "time" in each of our posts.)