A Dashboard with my first independent codes - Request for review by other members

[anish.ms]

Dear All,
Request someone to review my first dashboard with code before finishing the VBA course. I'm sure there are areas where the code can run faster than the way it is running now.

Copy required data between sheets
Loop through and format cells/values based on the cell value
Loop through and add comments from the cell value
Sort data when double click on column header

Thanks in advance!




Private Sub Worksheet_Activate()


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sh1 = "Dashboard"
Sh2 = "Review tracker"

LastRow = Sheets(Sh2).Cells(Rows.Count, "F").End(xlUp).Row
With Sheets(Sh1).Range("A2:J" & LastRow)
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
.ClearComments
End With
Sheets(Sh2).Range("C2:C" & LastRow).Copy
Sheets(Sh1).Range("A2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("F2:F" & LastRow).Copy
Sheets(Sh1).Range("B2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("E2:E" & LastRow).Copy
Sheets(Sh1).Range("C2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("H2:I" & LastRow).Copy
Sheets(Sh1).Range("D2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("I2:I" & LastRow).Copy
Sheets(Sh1).Range("E2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("L2:L" & LastRow).Copy
Sheets(Sh1).Range("F2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("W2:W" & LastRow).Copy
Sheets(Sh1).Range("I2").PasteSpecial xlPasteValues
Sheets(Sh2).Range("Y2:Y" & LastRow).Copy
Sheets(Sh1).Range("J2").PasteSpecial xlPasteValues

With Sheets(Sh1)

With Range("A2:I" & LastRow)
.Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
.Borders(xlInsideHorizontal).Weight = xlMedium
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Interior.Color = RGB(242, 242, 242)
End With

Set MyRange = .Range("F2:F" & LastRow)
For Each MyCell In MyRange
Select Case MyCell.Value

Case "Final report issued"
With .Range("F" & MyCell.Row, "I" & MyCell.Row)
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
.HorizontalAlignment = xlCenter
End With
.Range("F" & MyCell.Row, "F" & MyCell.Row).HorizontalAlignment = xlLeft

Case "Audit Announced"
With .Range("F" & MyCell.Row, "F" & MyCell.Row)
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
.HorizontalAlignment = xlLeft
End With

Case "Fieldwork commenced"
With .Range("F" & MyCell.Row, "G" & MyCell.Row)
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
.HorizontalAlignment = xlLeft
End With

Case "Field work completed"
With .Range("F" & MyCell.Row, "H" & MyCell.Row)
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
.HorizontalAlignment = xlLeft
End With

Case "Not yet due"
With .Range("F" & MyCell.Row, "F" & MyCell.Row)
.Font.Color = RGB(84, 130, 53)
.HorizontalAlignment = xlLeft
End With

Case "Deferred"
With .Range("F" & MyCell.Row, "F" & MyCell.Row)
.Font.Color = RGB(0, 51, 204)
.HorizontalAlignment = xlLeft
End With

Case "Cancelled"
With .Range("F" & MyCell.Row, "F" & MyCell.Row)
.Font.Color = RGB(192, 0, 0)
.HorizontalAlignment = xlLeft
End With
Case Else
End Select
MyCell.Value = Empty
Next MyCell

Sheets(Sh2).Range("J2:J" & LastRow).Copy
Sheets(Sh1).Range("F2").PasteSpecial xlPasteValues

Set MyRange = .Range("B2:B" & LastRow)
For Each MyCell In MyRange
If WorksheetFunction.CountIf(MyRange, MyCell.Value) > 1 Then
MyCell.Interior.Color = RGB(217, 217, 217)
End If
Next MyCell

Set MyRange = .Range("J2:J" & LastRow)
For Each MyCell In MyRange
If Not IsEmpty(MyCell) Then
.Range("B" & MyCell.Row).AddComment MyCell.Text
With .Range("B" & MyCell.Row).Comment.Shape.TextFrame.Characters.Font
.ColorIndex = 5
.Size = 9
.Name = "Century Gothic"
End With
.Range("B" & MyCell.Row).Comment.Shape.TextFrame.AutoSize = True
MyCell.Value = Empty
End If
Next MyCell

End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets(Sh1).Range("A1").Select
End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim KeyRange As Range
Dim ColumnCount As Integer
Dim LastRow As Long
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
ColumnCount = Range("A1:I" & LastRow).Columns.Count
Cancel = False
If Target.Row = 1 And Target.Column <= ColumnCount Then
Cancel = True
Set KeyRange = Range(Target.Address)
Range("A1:I" & LastRow).Sort Key1:=KeyRange, Header:=xlYes
End If
End Sub

[SamT]

There are #42# correct ways to write code in VBA. These are how I would do it. YMMV

Not 100% tested


Option Explicit

Private DoneDone As Boolean 'Can be used to prevent running all that when not needed

Private Sub Worksheet_Activate()
If Not DoneDone Then MakeDashboard
End Sub

Private Sub MakeDashboard()
TransferData
FormatDashboard
End Sub

Private Sub TransferData()
Dim Dashboard As Worksheet
Dim ReviewTracker As Worksheet
Dim LastRow As Long
Dim Cel As Range

Set Dashboard = Sheets("Dashboard")
Set ReviewTracker = Sheets("Review tracker")
LastRow = ReviewTracker.Cells(Rows.Count, "F").End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False


With Dashboard.UsedRange.Offset(1)
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
.ClearComments
End With

'Copying Formats. Next Sub will handle fixing that
With ReviewTracker.UsedRange.Offset(1)
.Columns("C").Copy Dashboard.Range("A2")
.Columns("E").Copy Dashboard.Range("B2")
.Columns("D").Copy Dashboard.Range("C2")
.Columns("H").Copy Dashboard.Range("D2")
.Columns("I").Copy Dashboard.Range("E2")
.Columns("L").Copy Dashboard.Range("F2")
.Columns("W").Copy Dashboard.Range("I2")
.Columns("Y").Copy Dashboard.Range("J2")
End With
End Sub

Private Sub FormatDashboard()
Dim LastRow As Long
Dim Cel As Range
Dim RangeB As Range

LastRow = .Cells(Rows.Count, "F").End(xlUp).Row

With Sheets("Dashboard")
With .UsedRange.Offset(1)
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
.ClearComments
End With

With .Range("A2:I" & LastRow)
.Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
.Borders(xlInsideHorizontal).Weight = xlMedium
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Interior.Color = RGB(242, 242, 242)
End With

For Each Cel In .Range("F2:F" & LastRow)
Select Case Cel.Value
Case "Final report issued"
StandardColors Cel
StandardColors Cel.Offset(, 3)
Cel.Offset(, 3).HorizontalAlignment = xlCenter
Case "Audit Announced"
StandardColors Cel
Case "Fieldwork commenced"
StandardColors Cel
StandardColors Cel.Offset(, 1)
Case "Field work completed"
StandardColors Cel
StandardColors Cel.Offset(, 2)
Case "Not yet due"
Cel.Font.Color = RGB(84, 130, 53)
Case "Deferred"
Cel.Font.Color = RGB(0, 51, 204)
Case "Cancelled"
Cel.Font.Color = RGB(192, 0, 0)
Case Else
End Select
'Cel.Value = Empty 'What???
Next Cel

Sheets(ReviewTracker).Range("J2:J" & LastRow).Copy
Sheets(Dashboard).Range("F2").PasteSpecial xlPasteValues

Set MyRaRangeBnge = .Range("B2:B" & LastRow)
For Each Cel In MyRange
If WorksheetFunction.CountIf(MyRange, Cel.Value) > 1 Then
Cel.Interior.Color = RGB(217, 217, 217)
End If
Next Cel

For Each Cel In .Range("J2:J" & LastRow)
If Not IsEmpty(Cel) Then
With Cel.Offset(, -7)
.AddComment Cel.Text
With .Comment.Shape.TextFrame
With .Characters.Font
.ColorIndex = 5
.Size = 9
.Name = "Century Gothic"
End With
.AutoSize = True
End With
End With
End If
Next Cel

.Range("A1").Select
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

DoneDone = True 'see note at top of module
End Sub

Private Function StandrdColors(Cel As Range)
With Cel
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
End With
End Function


Option Explicit

Private SortOrder As Long
Private LastSorted As Long

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row = 1 Then CustomSort Target, Cancel
End Sub

Private Sub CustomSort(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, UsedRange) Is Nothing Then Exit Sub

If Target.Column = LastSorted Then
'Allow sorting Ascending(1) and Descending(2). Will reverse each time
Select Case SortOrder
Case Is = 1: SortOrder = 2
Case Is = 2: SortOrder = 1
Case Else: SortOrder = 1
End Select
Else: SortOrder = 1 'default for new column
End If

Cancel = True
UsedRange.Sort Key1:=Target, Order1:=SortOrder, Header:=xlYes

End Sub


Oh yeah. Store this sub somewhere you can always find it
Sub ResetExcel()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation= xlCalculationAutomatic
End Sub

[anish.ms]

SamT, thanks for your time!
I saw your footer message, for the students to do their homework and find all the errors you leave in.
May I request your help if you don't mind. I'm getting error in calling the function StandrdColors and unable to figure it out.:think:

[Paul_Hossler]

1. Change this ...



Private Function StandrdColors(Cel As Range)
With Cel
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
End With
End Function





... to this



Private Function StandardColors(Cel As Range)
With Cel
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
End With
End Function






2. Change these lines



Dim RangeB As Range, MyRange As Range






Sheets("Review Tracker").Range("J2:J" & LastRow).Copy
Sheets("Dashboard").Range("F2").PasteSpecial xlPasteValues

[anish.ms]

Thanks Paul_Hossler (http://www.vbaexpress.com/forum/member.php?9803-Paul_Hossler)

[anish.ms]

Cool . The codes are running faster than the way I wrote
But I need to apply color for the range as given below. Is there any way to refer range in offset


Case "Final report issued"
StandardColors Cel
StandardColors Cel.Offset(, 1)
StandardColors Cel.Offset(, 2)
StandardColors Cel.Offset(, 3)
Cel.Offset(, 3).HorizontalAlignment = xlCenter



Sorting Ascending(1) and Descending(2) is not working for me
And finally I need the dashboard to be refreshed whenever there is a change in the Review Tracker. For example, Status in column "L" changed from "Field work completed" to "Final report issued"
Hence I changed the

DoneDone = False
Thanks in advance

[Paul_Hossler]

Some suggestions (and a few bigish changes)

1. I put the bulk of the processing code into standard modules (mod_Main and mod_Uility) to keep the worksheet modules small and focused on WS things

2. Some variable names were changed, just so I could keep them streight

3. Didn't understand
"Is there any way to refer range in offset" so I took a guess


Sub StandardColors(Cel As Range, Optional numCols As Long = 1)
With Cel.Resize(1, numCols)
.Interior.Color = RGB(0, 172, 141)
.Font.Color = RGB(242, 242, 242)
End With
End Sub




4. Sorting on a DC seems to work

5. Some of the values probably are sorted in the order that you want, but they are sorted correctly according to Excel. Some extra logic can most like get them into a human-logical order
So this is sorted by col D and the -3 is after -29 and before -31

Real names should work fine

27817

[SamT]

Paul is correct about the misspelling of the name of Procedure StandardColors

MyRaRangeBnge is an obvious typo. While I Declared ("Dim"med) RangeB as a Range, I did not change instances of MyRange to RangeB in that Procedure. Either change "MyRange" to "RangeB" or Declare MyRange. Then fix the typo to suit. I use "RangeB' since it refers to Column "B". YMMV

Sorting Ascending/Descending is not working since LastSorted is not set = Target.Column after Sorting, thus LastSorted is always Null or Empty.


Case "Final report issued"
StandardColors Cel.Resize(, 4)
Cel.Offset(, 3).HorizontalAlignment = xlCenter

Most of the increase in speed is because I used Object Variables ("Dashboard" and "ReviewTracker") in the first Procedure, instead of directly referencing the Worksheets. Note that in the second Procedure, I directly reference the Dashboard Worksheet. You can pick up a few CPU ticks by using an Object variable as I did in the other Procedure. Some speed was found by improved code, but not all.

I hope this helps your understanding.

[anish.ms]

Thank you very much Paul_Hossler (http://www.vbaexpress.com/forum/member.php?9803-Paul_Hossler) and
SamT (http://www.vbaexpress.com/forum/member.php?6494-SamT) for your time and support
Greatly appreciate and very helpful for my learning