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

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
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
427
Trebor76
T
B
  • Solved
Object required error
Replies
2
Views
141
Boston_Paul
B
H
  • Solved
Copy/Move Data from a table to another Sheet to a table
Replies
2
Views
331
himaruasuka
H
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
301
mumps
mumps
N
  • Question Question
My code is suddenly really slow
Replies
1
Views
369
RobP
R

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

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