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

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!

Code:

---


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

---

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

Not 100% tested

Code:

---

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

---

Code:

---

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

Code:

---

Sub ResetExcel()
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation= xlCalculationAutomatic
End Sub

---

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:

1. Change this ...

Code:

---

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

Code:

---

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

Code:

---

Dim RangeB As Range, MyRange As Range

---

Code:

---

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

---

Thanks Paul_Hossler

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

Code:

---

                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

Code:

---

DoneDone = False

---

Thanks in advance

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

Quote:

---

"Is there any way to refer range in offset"

---

so I took a guess

Code:

---

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

Attachment 27817

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.

Code:

---

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.

Thank you very much Paul_Hossler and
SamT for your time and support
Greatly appreciate and very helpful for my learning