Consulting

Results 1 to 9 of 9

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

  1. #1
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location

    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!

    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
    Attached Files Attached Files

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    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.
    Attached Files Attached Files

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Thanks Paul_Hossler

  6. #6
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    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
    Attached Files Attached Files

  7. #7
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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

    Capture.JPG
    Attached Files Attached Files
    Last edited by Paul_Hossler; 01-27-2021 at 02:34 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  8. #8
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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.
    Last edited by SamT; 01-27-2021 at 04:17 PM.
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  9. #9
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Thank you very much Paul_Hossler and
    SamT for your time and support
    Greatly appreciate and very helpful for my learning


Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •