Macro needs slimming down!

C

chuckles1066

Banned
Joined
Dec 20, 2004
Messages
372
I have cobbled together a couple of macros very kindly supplied by the geniuses on this forum and have also added in some code generated by the macro recorder.

Consequently, what I have works but I suspect its bloaty.

If anyone's got a spare five minutes, please feel free to critique my macro:
Code: 
Sub Separate_Controllers()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
Sheets("All Jobs").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
For z = 12 To LR
If Cells(z, 17).Value = "Overdue" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 3
End If
If Cells(z, 17).Value = "Raised & Completed Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 4
End If
If Cells(z, 17).Value = "In Progress" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 5
Range("A" & z & ":S" & z).Font.ColorIndex = 2
End If
If Cells(z, 17).Value = "Raised Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 6
End If
If Cells(z, 17).Value = "Outstanding" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 7
End If
If Cells(z, 17).Value = "Completed Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 8
End If
Next z
Rows("1:10").Delete
Cells.Select
Selection.AutoFilter
Cells.Select
    With Selection.Font
        .Name = "Trebuchet MS"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
On Error Resume Next
Set r = Application.InputBox("Highlight the column you wish to work with", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("ref").Select
    Rows("1:10").Select
    Selection.Copy
    Sheets("All Jobs").Select
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets(Array("All Jobs", "Homer", "Marge", "Bart", _
        "Lisa", "Maggie", "Smithers")).Select
    Sheets("All Jobs").Activate
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("All Jobs").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Rows("11:11").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets(Array("Homer", "Marge", "Bart", _
        "Lisa", "Maggie", "Smithers")).Select
    Rows("11:11").Select
    ActiveSheet.Paste
    Sheets("Homer").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("Marge").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("Bart").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("Lisa").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("Maggie").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("Smithers").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Sheets("All Jobs").Select
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you wish to save the individual sheets as separate workbooks?", vbYesNo + vbQuestion) = vbYes Then
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "ref" And sh.Name <> Master Then
            sh.Copy
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xls"
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
This section:
Code: 
If Cells(z, 17).Value = "Overdue" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 3
End If
If Cells(z, 17).Value = "Raised & Completed Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 4
End If
If Cells(z, 17).Value = "In Progress" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 5
Range("A" & z & ":S" & z).Font.ColorIndex = 2
End If
If Cells(z, 17).Value = "Raised Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 6
End If
If Cells(z, 17).Value = "Outstanding" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 7
End If
If Cells(z, 17).Value = "Completed Today" Then
Range("A" & z & ":S" & z).Interior.ColorIndex = 8

could/should be rewritten as:
Code: 
Select Case Cells(Z, 17).Value

Case "Overdue"
Range("A" & Z & ":S" & Z).Interior.ColorIndex = 3

Case "Raised & Completed Today"
Range("A" & Z & ":S" & Z).Interior.ColorIndex = 4

'etc
End Select
 
Upvote 0
Also - you don't need to select sheets/cells to perform actions on them, e.g this:
Code: 
Sheets("All Jobs").Activate
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("All Jobs").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:B").Select
    Selection.ColumnWidth = 12
    Range("A11:S11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Rows("11:11").Select
    Application.CutCopyMode = False
    Selection.Copy

could be this:
Code: 
With Sheets("All Jobs")

    .Rows("1:1").Insert shift:=xlDown
    .Cells.EntireColumn.AutoFit
    .Columns("AB").ColumnWidth = 12
    .Rows("11:11").Copy
    
End With

There are a few sections with unecessary selecting. Also, consider setting screenupdating to false and possibly calculation to manual - will considerably speed things up
 
Upvote 0
I have no idea what this macro is meant to do, but this is what I was able to clean up.

Code: 
Sub Separate_Controllers()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
Application.ScreenUpdating = False
Sheets("All Jobs").Select
LR = Range("A" & rows.Count).End(xlUp).row
For z = 12 To LR
    Select Case Cells(z, 17).Value
        Case "Overdue"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 3
        Case "Raised & Completed Today"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 4
        Case "In Progress"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 5
            Range("A" & z & ":S" & z).Font.ColorIndex = 2
        Case "Raised Today"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 6
        Case "Outstanding"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 7
        Case "Completed Today"
            Range("A" & z & ":S" & z).Interior.ColorIndex = 8
    End Select
Next z
rows("1:10").Delete
With Cells
    .AutoFilter
    With .Font
        .Name = "Trebuchet MS"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
On Error Resume Next
Set r = Application.InputBox("Highlight the column you wish to work with", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.column
t = Now
With ActiveSheet
    Master = .Name
    LastRow = .Cells(rows.Count, "A").End(xlUp).row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Sheets("ref").rows("1:10").Copy
Sheets(Array("All Jobs", "Homer", "Marge", "Bart", _
             "Lisa", "Maggie", "Smithers")).rows("1:1").Insert Shift:=xlDown
Sheets("All Jobs").Cells.EntireColumn.AutoFit
Columns("A:B").ColumnWidth = 12
Range("A11:S11").AutoFilter
rows("11:11").Copy Destination:=Sheets(Array("Homer", "Marge", "Bart", _
    "Lisa", "Maggie", "Smithers")).rows("11:11")
With Sheets(Array("Homer", "Marge", "Bart", "Lisa", "Maggie", "Smithers"))
    .Cells.EntireColumn.AutoFit
    .Columns("A:B").ColumnWidth = 12
    .Range("A11:S11").AutoFilter
End With
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you wish to save the individual sheets as separate workbooks?", vbYesNo + vbQuestion) = vbYes Then
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "ref" And sh.Name <> Master Then
            sh.Copy
            ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xls"
            ActiveWorkbook.Close
        End If
     Next sh
End If
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Never tried using worksheet formulas in code, but why not - seems to work.:)
Code: 
Dim arrValues
Dim lngColour
 
    arrValues = Array("Overdue", "Raised & Completed Today", "In Progress", "Raised Today", "Outstanding", "Completed Today")
 
    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    For Z = 12 To LastRow
 
        lngColour = Application.Match(Cells(Z, 17).Value, arrValues, 0)
        
        If Not IsError(lngColour) Then
        
            lngColour = lngColour + 2
 
            Range("A" & Z & ":S" & Z).Interior.ColorIndex = lngColour
            
            If lngcolor = 5 Then
                Range("A" & Z & ":S" & Z).Font.ColorIndex = 2
            End If

        End If
        
    Next Z
 
Upvote 0
Thanks for all the suggestions, I'll dissect the original macro and make the necessary changes.

MrKowz - there is an "all jobs" tab - the macro colour co-ordinates cells based on the job status (in progress, completed, etc) and then creates individual tabs for jobs relating to each employee (Bart, Homer etc). Finally, it gives the user the option to save the individual sheets as separate workbooks.

When I inherited this task, the guy doing it told me the whole process was taking him about an hour a day. Thanks to this macro kindly supplied by members of this forum, it takes me about ten seconds :-)
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
273
rlv01
R
C
  • Solved
VBA Too Slow
Replies
1
Views
312
Cubist
Cubist
C
  • Question Question
How to get my macro to stop at the last recognized line
Replies
6
Views
553
Coco1
C
R
  • Solved
Filter data set to #N/A, skip step entirely if none
Replies
3
Views
308
RoryA
RoryA
S
  • Question Question
Macro Formatting to all WS
Replies
4
Views
341
MARK858
MARK858

Forum statistics

Threads
1,224,616
Messages
6,179,909
Members
452,949
Latest member
beartooth91

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