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

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
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

J
  • Question Question
VBA code help
Replies
7
Views
87
Micron
M
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
344
smozgur
smozgur
A
  • Solved
Could not set the RowSource property. Invalid property value. Error 380
2
Replies
16
Views
267
RoryA
RoryA
B
  • Solved
refering to a worksheet with a changing name
2
Replies
17
Views
524
bdt
B
R
  • Solved
Macro To Move Files - Will Not Move .msg or .csv files
Replies
4
Views
110
rachel06
R

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

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