I have the following three macros all running in the same module. Each one is attached to its own button (3 buttons total). All three buttons take an average of 6-12 mins to run. As I am working on figuring out additional buttons that will check/review other criteria on the sheet, I am looking to improve this.
Could anyone help make these run quicker and/or look more elegant? I am still fairly new to VBA, so I am fairly sure there is a lot of redundancy in my code that is slowing it down and making it less elegant, I unfortunately don't know how to eliminate this. I've briefly explained the function of each code block below.
This first one removes existing color, then looks for any blanks, highlights them red, then for any " --Select--"
cells in yellow. This is to make sure the sheet isn't missing info.
Sub ItemVal()
'Validation, Checks Sheet For Uncompleted Sections
Application.ScreenUpdating = False
'Clear Color
Dim Clear As Range
Set Clear = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
Cell.Interior.ColorIndex = 0
Next Cell
'Blank Cells
Dim BlankCel As Range
Set BlankCel = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
If Cell.Value = "" Then
Cell.Interior.ColorIndex = 3
End If
Next Cell
Dim ImagTemp As Range
Set ImagTemp = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
If Cell.Value = "Please Complete Image Template" Then
Cell.Interior.ColorIndex = 6
End If
Next Cell
'Selection
Dim InOut As Range
Set InOut = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
If Cell.Value = " --Select--" Then
Cell.Interior.ColorIndex = 6
End If
Next Cell
Dim YesNo As Range
Set YesNo = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
If Cell.Value = " --Select Yes or No--" Then
Cell.Interior.ColorIndex = 6
End If
Next Cell
Dim SugLocLis As Range
Set SugLocLis = ThisWorkbook.Sheets(1).Range("AM3:AM5002")
For Each Cell In Range("AM3:AM5002")
If Cell.Value = " --" Then
Cell.Interior.ColorIndex = 6
End If
Next Cell
Application.ScreenUpdating = True
End Sub
This code clears all color again, then highlights each row based on the product type using specific colors, then sorts by that color. This is the slowest of the 3 macros:
Sub SortNColor()
'Sort + Colors Rows Based On Product Type
Application.ScreenUpdating = False
'Clear Color
Dim Clear As Range
Set Clear = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
Cell.Interior.ColorIndex = 0
Next Cell
'Color Coding Code
Set MyPlage = Range("AG3:AG5002")
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "btty"
Cell.EntireRow.Interior.ColorIndex = 20
Case Is = "clfn"
Cell.EntireRow.Interior.ColorIndex = 19
Case Is = "chdr"
Cell.EntireRow.Interior.ColorIndex = 24
Case Is = "dskp"
Cell.EntireRow.Interior.ColorIndex = 15
Case Is = "flrp"
Cell.EntireRow.Interior.ColorIndex = 16
Case Is = "flmt"
Cell.EntireRow.Interior.ColorIndex = 18
Case Is = "lslt"
Cell.EntireRow.Interior.ColorIndex = 35
Case Is = "pdt"
Cell.EntireRow.Interior.ColorIndex = 50
Case Is = "pstt"
Cell.EntireRow.Interior.ColorIndex = 36
Case Is = "rcdl"
Cell.EntireRow.Interior.ColorIndex = 37
Case Is = "smflmt"
Cell.EntireRow.Interior.ColorIndex = 38
Case Is = "tblp"
Cell.EntireRow.Interior.ColorIndex = 39
Case Is = "trklt"
Cell.EntireRow.Interior.ColorIndex = 40
Case Is = "vty"
Cell.EntireRow.Interior.ColorIndex = 20
Case Is = "wsc"
Cell.EntireRow.Interior.ColorIndex = 42
Case Is = "ocf"
Cell.EntireRow.Interior.ColorIndex = 43
Case Is = "oflmt"
Cell.EntireRow.Interior.ColorIndex = 44
Case Is = "opnt"
Cell.EntireRow.Interior.ColorIndex = 33
Case Is = "osmflmt"
Cell.EntireRow.Interior.ColorIndex = 32
Case Is = "owsc"
Cell.EntireRow.Interior.ColorIndex = 46
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
'Sorting Code
Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rngFirstRow = ws.Range("A3:FU3")
For Each rng In rngFirstRow.Cells
With ws.Sort
Set rngSort = rng.Resize(5000, 1)
.SortFields.Clear
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(204, 255, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 255, 204)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(204, 204, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(192, 192, 192)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(128, 128, 128)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(153, 51, 102)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(204, 255, 204)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(51, 153, 102)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 255, 153)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(153, 204, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 153, 204)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(204, 153, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 204, 153)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(51, 204, 204)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(153, 204, 0)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 204, 0)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(0, 204, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(0, 0, 255)
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 102, 0)
.SetRange rngSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next rng
Application.ScreenUpdating = True
End Sub
This one looks for any discontinued items and highlights them red and sorts them to the top. I couldn't get it to sort them to the bottom of the sheet, which would be preferred.
Sub DisRedSort()
Dim DISCONT As Range
Application.ScreenUpdating = False
Set DISCONT = ThisWorkbook.Sheets(1).Range("C3:C5002")
For Each Cell In Range("C3:C5002")
If Cell.Value = "Discontinued" Then
Cell.EntireRow.Interior.ColorIndex = 3
End If
Next Cell
Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rngFirstRow = ws.Range("A3:FU3")
For Each rng In rngFirstRow.Cells
With ws.Sort
Set rngSort = rng.Resize(5000, 1)
.SortFields.Clear
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(255, 0, 0)
.SetRange rngSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next rng
Application.ScreenUpdating = True
End Sub
Set rngSort = rng.Resize(5000, 1)
supposed to readSet rngSort = rng.Resize(1, 5000)
? \$\endgroup\$For Each rng In ws.Range("A3:FU3").Cells
and for each one you've gotSet rngSort = rng.Resize(5000, 1)
so you seem to be sorting a block of cells 1 column wide and 5000 rows deep. Find out how long the sorting takes and maybe raise on new post here on [cr] just looking at the sorting. \$\endgroup\$