Macro works but is clunky and slow

J

JanetStiles

New Member
Joined
Oct 29, 2018
Messages
1
Hi, I am brand new to macros and need some help. I have a sheet that needs to be split into multiple sheets, based on the criteria in column E. The data changes periodically so I have to run the macro every couple of days. I need the macro to clear the contents of the target sheet (without deleting the header row) then paste the rows from the data sheet, based on the criteria in column E, starting in row 2. There are 17 sheets. Below is the code I have come up with, putting together bits and pieces of code found on the web. The code below works but seems a bit clunky and is slow - it takes almost four minutes to complete it's run. Is there anything I can do to make things speed up? I feel like there should be a loop function or something so I don't have to have so many lines of code. Thank you!

Code: 
Sub Site()
a = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row


Worksheets("Clinics").Range("A2:F1500").ClearContents
Worksheets("CUMCBM").Range("A2:F1500").ClearContents
Worksheets("Foundation").Range("A2:F1500").ClearContents
Worksheets("Immanuel").Range("A2:F1500").ClearContents
Worksheets("LastingHope").Range("A2:F1500").ClearContents
Worksheets("Lakeside").Range("A2:F1500").ClearContents
Worksheets("McAuley").Range("A2:F1500").ClearContents
Worksheets("MercyCB").Range("A2:F1500").ClearContents
Worksheets("MercyCR").Range("A2:F1500").ClearContents
Worksheets("Midlands").Range("A2:F1500").ClearContents
Worksheets("MoValley").Range("A2:F1500").ClearContents
Worksheets("National").Range("A2:F1500").ClearContents
Worksheets("PrintCenter").Range("A2:F1500").ClearContents
Worksheets("Plainview").Range("A2:F1500").ClearContents
Worksheets("Schuyler").Range("A2:F1500").ClearContents
Worksheets("SVCNorth").Range("A2:F1500").ClearContents
Worksheets("SVCSouth").Range("A2:F1500").ClearContents


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "CL" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Clinics").Activate
            b = Worksheets("Clinics").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Clinics").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "CUMCBM" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("CUMCBM").Activate
            b = Worksheets("CUMCBM").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("CUMCBM").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "FND" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Foundation").Activate
            b = Worksheets("Foundation").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Foundation").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "IM" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Immanuel").Activate
            b = Worksheets("Immanuel").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Immanuel").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "LH" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("LastingHope").Activate
            b = Worksheets("LastingHope").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("LastingHope").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "LK" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Lakeside").Activate
            b = Worksheets("Lakeside").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Lakeside").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "MCA" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("McAuley").Activate
            b = Worksheets("McAuley").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("McAuley").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "MCB" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("MercyCB").Activate
            b = Worksheets("MercyCB").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MercyCB").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "MCR" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("MercyCR").Activate
            b = Worksheets("MercyCR").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MercyCR").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "MD" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Midlands").Activate
            b = Worksheets("Midlands").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Midlands").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "MV" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("MoValley").Activate
            b = Worksheets("MoValley").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MoValley").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "NAT" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("National").Activate
            b = Worksheets("National").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("National").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "PC" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("PrintCenter").Activate
            b = Worksheets("PrintCenter").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("PrintCenter").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "PL" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Plainview").Activate
            b = Worksheets("Plainview").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Plainview").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "SC" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("Schuyler").Activate
            b = Worksheets("Schuyler").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Schuyler").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "SVCN" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("SVCNorth").Activate
            b = Worksheets("SVCNorth").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("SVCNorth").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


For i = 2 To a


    If Worksheets("Data").Cells(i, 5).Value = "SVCS" Then
        
            Worksheets("Data").Rows(i).Copy
            Worksheets("SVCSouth").Activate
            b = Worksheets("SVCSouth").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("SVCSouth").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
        
    End If
Next


Application.CutCopyMode = False


End Sub
 
Last edited by a moderator:

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Hi & welcome to MrExcel.
How about
Code: 
Sub Site()
   Dim i As Long
   Dim Ary As Variant
   
   [COLOR=#0000ff]Ary = Array("CL", "Clinic", "CUMCBM", "CUMCBM", "FND", "Foundation")
[/COLOR]
   With Worksheets("Data")
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 2
         Sheets(Ary(i + 1)).UsedRange.Offset(, 1).ClearContents
         .Range("A1:F1").AutoFilter 5, Ary(i)
         .AutoFilter.Range.Copy Sheets(Ary(i + 1)).Range("A2")
      Next i
      .AutoFilterMode = False
   End With
End Sub
You'll need to add the rest of the filter criteria/sheet names to the array in blue

Also, when posting code, please use code tags, the # icon in the reply window
 
Last edited:
Upvote 0
To me your main issue is that you are looking fron 2 to last row every sing cell while it should be once only. By turning the screenupdating off at the beginning and back at the end, you should also save a bit of time.

Code: 
Sub Site()
Application.ScreenUpdating = false
a = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row


Sheets(Array("Clinics", "CUMCBM", "Foundation", "Immanuel", "LastingHope", "Lakeside", "McAuley", "MercyCB", "MercyCR", "Midlands", "MoValley", "National", "PrintCenter", "Plainview", "Schuyler", "SVCNorth", "SVCSouth")).Select
    Range("a2:f1500").ClearContents
Worksheets("Data").Select


For i = 2 To a
 Select Case Cells(i, 5).Value
    Case "CL"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Clinics").Activate
            b = Worksheets("Clinics").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Clinics").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "CUMCBM"
            Worksheets("Data").Rows(i).Copy
            Worksheets("CUMCBM").Activate
            b = Worksheets("CUMCBM").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("CUMCBM").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "FND"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Foundation").Activate
            b = Worksheets("Foundation").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Foundation").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "IM"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Immanuel").Activate
            b = Worksheets("Immanuel").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Immanuel").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "LH"
            Worksheets("Data").Rows(i).Copy
            Worksheets("LastingHope").Activate
            b = Worksheets("LastingHope").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("LastingHope").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "LK"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Lakeside").Activate
            b = Worksheets("Lakeside").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Lakeside").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
     Case "MCA"
            Worksheets("Data").Rows(i).Copy
            Worksheets("McAuley").Activate
            b = Worksheets("McAuley").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("McAuley").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "MCB"
            Worksheets("Data").Rows(i).Copy
            Worksheets("MercyCB").Activate
            b = Worksheets("MercyCB").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MercyCB").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "MCR"
            Worksheets("Data").Rows(i).Copy
            Worksheets("MercyCR").Activate
            b = Worksheets("MercyCR").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MercyCR").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "MD"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Midlands").Activate
            b = Worksheets("Midlands").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Midlands").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "MV"
            Worksheets("Data").Rows(i).Copy
            Worksheets("MoValley").Activate
            b = Worksheets("MoValley").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("MoValley").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "NAT"
            Worksheets("Data").Rows(i).Copy
            Worksheets("National").Activate
            b = Worksheets("National").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("National").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "PC"
            Worksheets("Data").Rows(i).Copy
            Worksheets("PrintCenter").Activate
            b = Worksheets("PrintCenter").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("PrintCenter").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "PL"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Plainview").Activate
            b = Worksheets("Plainview").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Plainview").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "SC"
            Worksheets("Data").Rows(i).Copy
            Worksheets("Schuyler").Activate
            b = Worksheets("Schuyler").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("Schuyler").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "SVCN"
            Worksheets("Data").Rows(i).Copy
            Worksheets("SVCNorth").Activate
            b = Worksheets("SVCNorth").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("SVCNorth").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
    Case "SVCS"
            Worksheets("Data").Rows(i).Copy
            Worksheets("SVCSouth").Activate
            b = Worksheets("SVCSouth").Cells(Rows.Count, 1).End(xlUp).Row
            Worksheets("SVCSouth").Cells(b + 1, 1).Select
            ActiveSheet.Paste
            Worksheets("Data").Activate
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

I can't test it unfortunately
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Need Help VBA
2
Replies
10
Views
300
Trebor76
T
B
  • Solved
Object required error
Replies
2
Views
101
Boston_Paul
B
H
  • Solved
Copy/Move Data from a table to another Sheet to a table
Replies
2
Views
184
himaruasuka
H
N
  • Question
My code is suddenly really slow
Replies
1
Views
332
RobP
R
A
  • Question
Make a new worksheet at every page break in a worksheet & name each sheet after a value from a cell.
Replies
6
Views
348
Arcomvi
A

Forum statistics

Threads
1,221,310
Messages
6,159,173
Members
451,543
Latest member
cesymcox

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top