Part 2: Counting cells based on interior color of the cell & Value

In the previous post we discussed about counting cells based on color now there is extension to include color and values both or only color.

= CountColorCode(RangeArea As Range, Criteria_Cell As Range, Optional Consider_Value As Boolean = False)

Criteria_Cell is Range where we need to look for colored cells and count themcRange is the criteria range, which needs to be searched
Consider_Value is bollen True/False if left alone default is False and value of cell is not taken in consideration

Download the file for codes and example

<

Counting cells based on interior color of the cell

Paste the code in vba standerd module in Excel:

Public Function CountColorCode(rng As Range, cRange As Range) As Integer

Dim I As Integer

For Each Cell In rng
If Cell.Interior.ColorIndex = cRange.Interior.ColorIndex Then
I = I + 1
End If

Next

CountColorCode = I

End Function

------------Testing the function-----

Syntax rng As Range = CountColorCode(rng, cRange)

Rng is Range where we need to look for colored cells and count them
cRange s the criteria range which needs to be searched

eg: we need to count the cells in range “A1:B20” which color same as cell D1
Then the formula is = CountColorCode(A1:B20, D1)

Transpose a multidimensional table into a two dimensional table

Pivot’s are very effective tool in Excel but only if we have data stored in rolling format; where as most of people store data in running tables making it useless for pivots, and often there are times when we need to append this data to some database which makes it critical.

The codes below will help you use a Custom VBA Excel Function to transpose a running table into rolling table the syntax is TransArryaSize(strtRange As Range, cOffset As Variant, endRange As Range)

Paste the code below in standard VBA module try this macro to test the fuction


Sub TestConvertToTranspose()
Call TransArryaSize(Range("E11"), 2, Range("J37"))
' E11 is first cell of table
' 2 are the first two column that will remain as it is
' J37 is last cell of table
End Sub





"************Paste it from hear on in any VBA module***********

Function TransArryaSize(strtRange As Range, cOffset As Variant, endRange As Range)

' Trnaspose Function by Ritwik @ http://ritwik-shukla-vb.blogspot.com

Dim RowCount, ColumnCount As Integer

RowCount = endRange.Row - strtRange.Row
ColumnCount = endRange.Column - strtRange.Column + 1

Range(strtRange.Offset(1, 0), Cells(endRange.Row, strtRange.Column + cOffset - 1)).Copy
Sheets.Add
Range("A2").Select
ActiveSheet.Name = "Trans"


For I = 1 To ColumnCount - cOffset
Sheets("Trans").Cells(65536, 1).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyColumn

Next I


Application.CutCopyMode = False

Sheets("Data").Activate
Sheets("Data").Cells(strtRange.Row, strtRange.Column + cOffset).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

Sheets("Trans").Activate


For I = 1 To RowCount

Sheets("Trans").Cells(65536, (cOffset + 1)).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyRow

Next I

Application.CutCopyMode = False

For N = 1 To RowCount

Sheets("Data").Activate
Sheets("Data").Cells(strtRange.Row + N, strtRange.Column + cOffset).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Trans").Activate
Sheets("Trans").Cells(65536, (cOffset + 2)).Select
Selection.End(xlUp).Offset(1, 0).Select
Call copyRow

Next N

End Function

Function copyColumn()
'
' To Copy Column data by mulitiplying
' 3/5/2009 by Ritwik
'

'


Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Function


Function copyRow()
'
' To Copy Row Data into Transpose from Row
' 3/5/2009 by Ritwik
'
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

End Function