VBA Express : Excel - Coloring listviewitems based on a condition

Excel

Coloring listviewitems based on a condition

Ease of Use

Intermediate

Version tested with

2002, 2003

Submitted by:

Charlize

Description:

Bring some colour to your listview to easily spot problem areas that needs to be dealt with.

Discussion:

Invoicetracking of your customers is a necessary step to keep your financial situation healthy. When an invoice is due and not paid the line will light up red to get your attention. Possible enhancement is doubleclicking on a line to produce a reminder to your client.

Code:

instructions for use

			--- module code 
Option Explicit 
 
Sub showing_form_listview() 
    UserForm1.Show 
End Sub 
 
 '---------------------------------------------------------------------------------------
 ' Procedure : xlLastRow
 ' DateTime  : 8/09/2006 00:49
 ' Purpose   : Finding the last row of a sheet
 '---------------------------------------------------------------------------------------
 
Function xlLastRow(Optional WorksheetName As String) As Long 
     
     'Check for optional worksheetname else use activesheet
    If WorksheetName = vbNullString Then 
        WorksheetName = ActiveSheet.Name 
    End If 
     
     '    find the last populated row in a worksheet
    With Worksheets(WorksheetName) 
        xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _ 
        xlWhole, xlByRows, xlPrevious).Row 
    End With 
     
End Function 
--- End module code 
--- userform code 
 '---------------------------------------------------------------------------------------
 ' Module    : UserForm1.initialize
 ' DateTime  : 8/09/2006 00:46
 ' Author    : Charlize
 ' Purpose   : Filling a listview and coloring items based on certain condition
 '             In this case the invoices that are due and due date < today
 '---------------------------------------------------------------------------------------
 
Option Explicit 
 
Private Sub UserForm_Initialize() 
     
    Dim startrow As Integer 'beginning of data
    Dim endrow As Integer 'end of data
    Dim pos As Integer 'rowno
    Dim lv_item As Integer 'listview item no
    Dim counting As Integer 'loopvariable to go through data
     
    startrow = 2 
    endrow = xlLastRow("Data") 
    pos = 2 
    lv_item = 1 
     
    With ListView1 
         'gives me headers at the top
        .View = lvwReport 
         'defining the columnheaders
        With .ColumnHeaders 
            .Clear 
            .Add , , "Client", 85 
            .Add , , "Invoice date", 60 
            .Add , , "Due date", 60 
            .Add , , "Amount", 65 
            .Add , , "Date payment", 60 
            .Add , , "Amount due", 65 
        End With 
         
        .HideColumnHeaders = False 
        .Appearance = cc3D 
        .FullRowSelect = True 
         
        For counting = startrow To endrow 
            If Worksheets("Data").Range("C" & pos).Value < Date And Worksheets("Data").Range("F" & pos).Value > 0 Then 
                .ListItems.Add , , Worksheets("Data").Range("A" & pos) 
                .ListItems(lv_item).ForeColor = RGB(255, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("B" & pos), vbGeneralDate) 
                .ListItems(lv_item).ListSubItems.Item(1).ForeColor = RGB(255, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("C" & pos), vbGeneralDate) 
                .ListItems(lv_item).ListSubItems.Item(2).ForeColor = RGB(255, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatCurrency(Worksheets("Data").Range("D" & pos)) 
                .ListItems(lv_item).ListSubItems.Item(3).ForeColor = RGB(255, 0, 0) 
                 'A litte check to see if something is filled in. Otherwise you'll get an error
                If Worksheets("Data").Range("E" & pos) <> vbNullString Then 
                    .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("E" & pos), vbShortDate) 
                    .ListItems(lv_item).ListSubItems.Item(4).ForeColor = RGB(255, 0, 0) 
                Else 
                    .ListItems(lv_item).ListSubItems.Add , , Worksheets("Data").Range("E" & pos) 
                    .ListItems(lv_item).ListSubItems.Item(4).ForeColor = RGB(255, 0, 0) 
                End If 
                .ListItems(lv_item).ListSubItems.Add , , FormatCurrency(Worksheets("Data").Range("F" & pos)) 
                .ListItems(lv_item).ListSubItems.Item(5).ForeColor = RGB(255, 0, 0) 
            Else 
                .ListItems.Add , , Worksheets("Data").Range("A" & pos) 
                .ListItems(lv_item).ForeColor = RGB(0, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("B" & pos), vbGeneralDate) 
                .ListItems(lv_item).ListSubItems.Item(1).ForeColor = RGB(0, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("C" & pos), vbGeneralDate) 
                .ListItems(lv_item).ListSubItems.Item(2).ForeColor = RGB(0, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , FormatCurrency(Worksheets("Data").Range("D" & pos)) 
                .ListItems(lv_item).ListSubItems.Item(3).ForeColor = RGB(0, 0, 0) 
                If Worksheets("Data").Range("E" & pos) <> vbNullString Then 
                    .ListItems(lv_item).ListSubItems.Add , , FormatDateTime(Worksheets("Data").Range("E" & pos), vbShortDate) 
                    .ListItems(lv_item).ListSubItems.Item(4).ForeColor = RGB(0, 0, 0) 
                Else 
                    .ListItems(lv_item).ListSubItems.Add , , Worksheets("Data").Range("E" & pos) 
                    .ListItems(lv_item).ListSubItems.Item(4).ForeColor = RGB(0, 0, 0) 
                End If 
                .ListItems(lv_item).ListSubItems.Add , , FormatCurrency(Worksheets("Data").Range("F" & pos)) 
                .ListItems(lv_item).ListSubItems.Item(5).ForeColor = RGB(0, 0, 0) 
            End If 
            lv_item = lv_item + 1 
            pos = pos + 1 
        Next counting 
         
    End With 
     
End Sub 
--- End of userform code

How to use:

Use alt+f11 to open vb editor
use right click on left side of screen (your project) to insert module
do the same to insert form
copy module code to the module you added
copy code of form to the formcode
doubleclick on left side of project on the form with left mouse button
rightclick on the properties of the form
add a microsoft listview control 6.0 (sp2) (put a checkmark)
drag this listviewcontrol to the form and give it his shape
remove the --- module and the rest of this --- marks before running code
close vb editor
hit alt+f8 and run macro to show

Test the code:

Add some lines with data. Only the column with date payment can be blank otherwise you'll get an error. Try adding data with invoices due and not paid and not due and unpaid. Lines in red are due and unpaid (in form)

Sample File:

Listview-v4 - colour.zip 14.7KB

Approved by mdmackillop

This entry has been viewed 382 times.