Posts Tagged ‘VBA’

How to find and color duplicate values with Excel and VBA

December 15th, 2009

The obvious answer to the above question could be “by using conditional formatting, fool!” That’s true.  We could easily write a formula checking if the value just entered is a duplicate and, if it’s true, change accordingly the cell background color. We could ….. but

… what I really want is to use the same color for each duplicated value. And at the same time, use a different color for different values. It might sound complicated, but is not and the animation below should settle all the doubts.

How to find and color duplicate values with Excel and VBA

I also like the idea of having an option of easily changing the colors. To be honest, I don’t have a clue about how I could accomplish it with conditional formatting only.  And since I don’t have a clue I decided to use VBA.

In the first step I prepared a list of colors I want to use. It’s nothing, but a range with colored cells (we simply use Excel formatting).

How to find and color duplicate values with Excel and VBA

We can easily choose and change colors for duplicate values

Every time our macro finds a duplicate value in a chosen column, it will get the color from one of previously colored cells (our color list mentioned above).  Starting from the top one and moving down. When it reaches the end it will – surprise, surprise :) – start from the beginning.

Because I want my macro to run and refresh cell colors every time I change a value in a selected row I assigned the macro to Excel onChange event. And finally, my macro:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngKolory As Range

Dim rngDoPokolorowania As Range

Dim LicznikKolorow As Integer

Dim Licznik As Integer

Dim rngKolumna As Range

Dim rngDaneWypelnione As Range

' cells with colors to choose from

Set rngKolory = wksKolory.Range("rngKoloryStart").Resize(wksKolory.Range("settIleKolorow").Value, 1)

' cells with data to be "colored"

Set rngDoPokolorowania = wksDane.Range(Range("rngDaneStart"), Cells(65535, Range("rngDaneStart").Column).End(xlUp))

' column with data

Set rngKolumna = Columns("B")

With wksDane

Set rngDaneWypelnione = .Range(.Range("rngDaneStart"), .Range("rngDaneStart").Offset(10000).End(xlUp))

End With

If Not Intersect(Target, rngKolumna) Is Nothing Then

Application.ScreenUpdating = False '

' Let's clear the whole data area (set background color to default)

rngDaneWypelnione.Resize(rngDaneWypelnione.Count + 1).Interior.ColorIndex = _

wksKolory.Range("rngDomyslneTlo").Interior.ColorIndex

LicznikKolorow = 1 ' color counter reset

With rngDoPokolorowania

' first cell

If Application.WorksheetFunction.CountIf(rngDoPokolorowania, .Cells(1).Value) > 1 Then

.Cells(1).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex

LicznikKolorow = LicznikKolorow + 1

If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1

End If

'more than one cell

If rngDaneWypelnione.Count > 1 Then

' for following cells

For Licznik = 2 To .Count

If Application.WorksheetFunction.CountIf(rngDoPokolorowania, _

.Cells(Licznik).Value) > 1 Then

If Application.WorksheetFunction.CountIf(Range("rngDaneStart").Resize(Licznik - 1), .Cells(Licznik).Value) > 0 Then

.Cells(Licznik).Interior.ColorIndex = _

rngDaneWypelnione.Find(what:=.Cells(Licznik).Value, after:=.Cells(Licznik), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex

Else

.Cells(Licznik).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex

LicznikKolorow = LicznikKolorow + 1

If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1

End If

End If

Next Licznik

End If

End With

Application.ScreenUpdating = True

End If

End Sub

This might not be the most optimal solution, but in simple cases will play it’s role just fine.

Marcin

Separating lines from multi-line Excel cell

November 25th, 2009

A couple of weeks ago I wrote how to get rid of line breaks (inserted earlier by the shortcut ALT+ENTER) from an Excel cell. Today I would like to continue the subject of multi-line text strings in Excel cells and tell you how to separate and display only one, chosen, row of text.  It should look like this:

Separating lines from multi-line text strings in Excel

As it’s usually the case with Excel, we can approach the problem from many sides.  I set my mind on fitting everything into one formula and using Excel text function MID(), which in my example chooses and displays the correct row (other functions fulfill only an auxiliary role). My formula from the cell $D$11 looks like below:

=IF(OR(D11-1>LEN(B8)-LEN(SUBSTITUTE(B8,CHAR(10),"")),D11<1),"Given row number should be higher that 0 and lower then the total rows number",MID(B8,IF(D11=1,1,SEARCH("@",SUBSTITUTE(B8,CHAR(10),"@",D11-1))+1),IF(D11=LEN(B8)-LEN(SUBSTITUTE(B8,CHAR(10),""))+1,LEN(B8),SEARCH("@",SUBSTITUTE(B8,CHAR(10),"@",D11)))-IF(D11=1,0,SEARCH("@",SUBSTITUTE(B8,CHAR(10),"@",D11-1)))))

The cell $B$8, as you already noticed, contains our source material – text string divided into many separate rows by break a line character (inserted using the shortcut ALT+ENTER).

For all those who prefer VBA code and user defined functions, I have prepared an example of how such a function could look like. I used probably the easiest approach and took advantage of VBA SPLIT() function. The function has it’s flaws but in this simple case, should be just fine.

I named my UDF (User Defined Function) GetTextRow, and the function takes two parameters. It needs to know where (what cell) is the string we are going to use as a source data, and what row number we want to display. The result is shown on the animation below:

Separating lines from multi-line text strings in Excel
And my VBA code:

Function GetTextRow(WhereFrom As Range, _
                      RowNumber As Integer)

Dim Temporary As Long
Dim TemporaryArray As Variant

' First, lets check if the text in the pointed cell is divided into separate rows at all
' If this is not the case, we will display the whole text

Temporary = InStr(WhereFrom.Value, Chr(10))
If Temporary = 0 Then
    GetTextRow = WhereFrom.Value ' return text from pointed cell
Else
    ' lets also check if the row number the user provided is not too big.

    TemporaryArray = Split(WhereFrom.Value, Chr(10))
    If RowNumber - 1 > UBound(TemporaryArray) Or _
    RowNumber = 0 Then
        GetTextRow = "It is strongly recommended to think over the row number you used"
    Else
    ' if everything is all right the function returns (displays) the chosen row
        GetTextRow = TemporaryArray(RowNumber - 1)
    End If

End If

End Function

Marcin