This is how to do it, open the bas file which is a txt file, copy this part
Function ExtCell( _
prop As String, _
Optional rng As Variant, _
Optional rar As Boolean = False _
) As Variant
'Copyright (C) 2002, Harlan Grove
'This is free software. It's use in derivative works is covered
'under the terms of the Free Software Foundation's GPL. See
'
http://www.gnu.org/copyleft/gpl.html
Dim ws As Worksheet, wb As Workbook, rv As Variant
Dim i As Long, j As Long, m As Long, n As Long, t As String
Application.Volatile True
If TypeOf rng Is Range Then
If rar Then
Set rng = rng.Areas(1)
Else
Set rng = rng.Areas(1).Cells(1, 1)
End If
ElseIf IsMissing(rng) Then
Set rng = ActiveCell
Else
ExtCell = CVErr(xlErrRef)
Exit Function
End If
prop = LCase(prop)
m = rng.Rows.Count
n = rng.Columns.Count
rv = rng.Value
Set ws = rng.Worksheet
Set wb = ws.Parent
Select Case prop
Case "across" 'from later 123 versions - limited usefulness!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -( _
rng.Cells(i, j).HorizontalAlignment = _
xlHAlignCenterAcrossSelection _
)
Next j
Next i
Else
rv = -( _
rng.HorizontalAlignment = _
xlHAlignCenterAcrossSelection _
)
End If
Case "address" 'from CELL - limited usefulness!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Address
Next j
Next i
Else
rv = rng.Address
End If
Case "backgroundcolor" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Interior.ColorIndex
Next j
Next i
Else
rv = rng.Interior.ColorIndex
End If
Case "bold" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).Font.Bold)
Next j
Next i
Else
rv = -(rng.Font.Bold)
End If
Case "bottomborder" 'from later 123 versions - USEFUL!
'Note: many possible return values! wrap inside SIGN to test T/F
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeBottom).LineStyle - _
xlLineStyleNone
Next j
Next i
Else
rv = rng.Borders(xlEdgeBottom).LineStyle - xlLineStyleNone
End If
Case "bottombordercolor" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeBottom).ColorIndex
Next j
Next i
Else
rv = rng.Borders(xlEdgeBottom).ColorIndex
End If
Case "col", "column" 'from CELL - pointless - use COLUMN instead!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Column
Next j
Next i
Else
rv = rng.Column
End If
Case "color" 'from CELL - limited usefulness
'NOTE: differences between Excel & 123 - Excel's returns 1 whenever
'there's a color specified for EITHER positive OR negative values
'in the number format, e.g., 1 for format "[Black]0;-0;0" but not
'for format "0;-0;[Green]0"
'Another place where Excel doesn't conform to it's documentation!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = Evaluate( _
"=CELL(""Color""," & _
rng.Cells(i, j).Address(True, True, xlA1, True) & _
")" _
)
Next j
Next i
Else
rv = Evaluate( _
"=CELL(""Color""," & _
rng.CellsAddress(True, True, xlA1, True) & _
")" _
)
End If
Case "columnhidden"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).EntireColumn.Hidden
Next j
Next i
Else
rv = rng.EntireColumn.Hidden
End If
Case "comment"
If rar Then
For i = 1 To m
For j = 1 To n
If Not rng.Cells(i, j).Comment Is Nothing Then
rv(i, j) = rng.Cells(i, j).Comment.Text
Else
rv(i, j) = ""
End If
Next j
Next i
Else
If Not rng.Comment Is Nothing Then
rv = rng.Comment.Text
Else
rv = ""
End If
End If
Case "contents", "value" 'absolutely pointless - compatibility only
'DOME - nothing more to do!
Case "coord" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = "'" & ws.Name & "'!" & _
rng.Cells(i, j).Address
Next j
Next i
Else
rv = "'" & ws.Name & "'!" & rng.Address
End If
Case "currentarray" 'NOTE: returns Range addresses!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).CurrentArray.Address
Next j
Next i
Else
rv = rng.CurrentArray.Address
End If
Case "currentregion" 'NOTE: returns Range addresses!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).CurrentRegion.Address
Next j
Next i
Else
rv = rng.CurrentRegion.Address
End If
'different characteristics grouped for efficiency
'TYPE needed for backward compatibility w/123 but otherwise useless
'DATATYPE and FORMULATYPE are options in later 123 versions'
@Cell
'no need for them but included to make 123 conversion easier
Case "datatype", "formulatype", "type"
t = Left(prop, 1)
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = IIf( _
t = "f" And rng.Cells(i, j).HasFormula, _
"f", _
"" _
)
If rng.Cells(i, j).Formula = "" Then
rv(i, j) = rv(i, j) & "b"
ElseIf IsNumeric("0" & CStr(rng.Cells(i, j).Value)) _
Or (t = "t" And IsError(rng.Cells(i, j).Value)) Then
rv(i, j) = rv(i, j) & "v"
ElseIf rng.Cells(i, j).Value = CVErr(xlErrNA) Then
rv(i, j) = rv(i, j) & "n"
ElseIf IsError(rng.Cells(i, j).Value) Then
rv(i, j) = rv(i, j) & "e"
Else
rv(i, j) = rv(i, j) & "l"
End If
Next j
Next i
Else
rv = IIf( _
t = "f" And rng.HasFormula, _
"f", _
"" _
)
If rng.Formula = "" Then
rv = rv & "b"
ElseIf IsNumeric("0" & CStr(rng.Value)) _
Or (t = "t" And IsError(rng.Value)) Then
rv = rv & "v"
ElseIf rng.Value = CVErr(xlErrNA) Then
rv = rv & "n"
ElseIf IsError(rng.Value) Then
rv = rv & "e"
Else
rv = rv & "l"
End If
End If
Case "filedate" 'from later 123 versions - limited usefulness!
t = wb.BuiltinDocumentProperties("Last Save Time") 'invariant!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "filename" 'from CELL - limited usefulness!
'A testament to Microsoft's hypocracy! They could include this from
'123R2.2 (it wasn't in 123R2.0x), modify it in Excel 4.0 to include
'the worksheet name, but they can't make any other changes to CELL?!
t = Evaluate( _
"=CELL(""Filename""," & _
rng.Address(True, True, xlA1, True) & _
")" _
) 'invariant!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "fontface", "fontname", "typeface" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Font.Name
Next j
Next i
Else
rv = rng.Font.Name
End If
Case "fontsize", "pitch", "typesize" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Font.Size
Next j
Next i
Else
rv = rng.Font.Size
End If
Case "format" 'from CELL
'Backwards compatibility w/123 - unnecessary
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = Evaluate( _
"=CELL(""Format""," & _
rng.Cells(i, j).Address(True, True, xlA1, True) & _
")" _
)
Next j
Next i
Else
rv(i, j) = Evaluate( _
"=CELL(""Format""," & _
rng.Address(True, True, xlA1, True) & _
")" _
)
End If
Case "formula"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Formula
Next j
Next i
Else
rv = rng.Formula
End If
Case "formulaarray" 'questionable usefulness
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).FormulaArray
Next j
Next i
Else
rv = rng.FormulaArray
End If
Case "formulahidden"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).FormulaHidden)
Next j
Next i
Else
rv = -(rng.FormulaHidden)
End If
Case "formulalocal"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).FormulaLocal
Next j
Next i
Else
rv = rng.FormulaLocal
End If
Case "formular1c1"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).FormulaR1C1
Next j
Next i
Else
rv = rng.FormulaR1C1
End If
Case "formular1c1local"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).FormulaR1C1Local
Next j
Next i
Else
rv = rng.FormulaR1C1Local
End If
Case "halign", "horizontalalignment" 'from later 123 versions
'Note: different return values than 123. 0 = general alignment
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).HorizontalAlignment - _
xlHAlignGeneral
Next j
Next i
Else
rv = rng.HorizontalAlignment - xlHAlignGeneral
End If
Case "hasarray"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).HasArray)
Next j
Next i
Else
rv = -(rng.HasArray)
End If
Case "hasformula"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).HasFormula)
Next j
Next i
Else
rv = -(rng.HasFormula)
End If
Case "hashyperlink", "hashyperlinks"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).Hyperlinks.Count > 0)
Next j
Next i
Else
rv = -(rng.Hyperlinks.Count > 0)
End If
Case "height", "rowheight" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Height
Next j
Next i
Else
rv = rng.Height
End If
Case "hidden" 'see ColumnHidden and RowHidden - this is less useful
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).Hidden)
Next j
Next i
Else
rv = -(rng.Hidden)
End If
Case "hyperlinkaddress"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Hyperlinks(1).Address
Next j
Next i
Else
rv = rng.Hyperlinks(1).Address
End If
Case "indentlevel"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).rng.IndentLevel
Next j
Next i
Else
rv = rng.rng.IndentLevel
End If
Case "italic" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).Font.Italic)
Next j
Next i
Else
rv = -(rng.Font.Italic)
End If
Case "left"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Left
Next j
Next i
Else
rv = rng.Left
End If
Case "leftborder" 'from later 123 versions
'Note: many possible return values! wrap inside SIGN to test T/F
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeLeft).LineStyle - _
xlLineStyleNone
Next j
Next i
Else
rv = rng.Borders(xlEdgeLeft).LineStyle - xlLineStyleNone
End If
Case "leftbordercolor" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeLeft).ColorIndex
Next j
Next i
Else
rv = rng.Borders(xlEdgeLeft).ColorIndex
End If
Case "locked", "protect" 'from CELL
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).Locked)
Next j
Next i
Else
rv = -(rng.Locked)
End If
Case "mergearea" 'NOTE: returns Range addresses!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).MergeArea.Address
Next j
Next i
Else
rv = rng.MergeArea.Address
End If
Case "mergecells"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).MergeCells)
Next j
Next i
Else
rv = -(rng.MergeCells)
End If
Case "name"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Name
Next j
Next i
Else
rv = rng.Name
End If
Case "numberformat"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).NumberFormat
Next j
Next i
Else
rv = rng.NumberFormat
End If
Case "numberformatlocal"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).NumberFormatLocal
Next j
Next i
Else
rv = rng.NumberFormatLocal
End If
Case "orientation", "rotation" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Orientation
Next j
Next i
Else
rv = rng.Orientation
End If
Case "parentheses" 'from CELL
'Backwards compatibility w/123 - unnecessary
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = Evaluate( _
"=CELL(""Parentheses""," & _
rng.Cells(i, j).Address(True, True, xlA1, True) & _
")" _
)
Next j
Next i
Else
rv = Evaluate( _
"=CELL(""Parentheses""," & _
rng.Address(True, True, xlA1, True) & _
")" _
)
End If
Case "pattern" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Interior.Pattern - _
xlPatternNone
Next j
Next i
Else
rv = rng.Interior.Pattern - xlPatternNone
End If
Case "patterncolor" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Interior.PatternColorIndex
Next j
Next i
Else
rv = rng.Interior.PatternColorIndex
End If
Case "prefix", "prefixcharacter" 'from CELL
'Backwards compatibility w/123 - unnecessary
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = Evaluate( _
"=CELL(""Prefix""," & _
rng.Cells(i, j).Address(True, True, xlA1, True) & _
")" _
)
Next j
Next i
Else
rv = Evaluate( _
"=CELL(""Prefix""," & _
rng.Address(True, True, xlA1, True) & _
")" _
)
End If
Case "rightborder" 'from later 123 versions
'Note: many possible return values! wrap inside SIGN to test T/F
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeRight).LineStyle - _
xlLineStyleNone
Next j
Next i
Else
rv = rng.Borders(xlEdgeRight).LineStyle - xlLineStyleNone
End If
Case "rightbordercolor" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeRight).ColorIndex
Next j
Next i
Else
rv = rng.Borders(xlEdgeRight).ColorIndex
End If
Case "row" 'from CELL - pointless - use ROW instead!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Row
Next j
Next i
Else
rv = rng.Row
End If
Case "rowhidden"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).EntireRow.Hidden)
Next j
Next i
Else
rv = -(rng.EntireRow.Hidden)
End If
Case "scrollarea"
'Who needs consistency?! Why doesn't this return a Range object?
t = ws.ScrollArea 'invariant!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "sheet", "worksheet" 'from later 123 versions - USEFUL!
t = ws.Index 'invariant!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "sheetname", "worksheetname" 'from later 123 versions - USEFUL!
t = ws.Name 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "sheetcount", "sheetscount", "worksheetcount", "worksheetscount"
t = wb.Worksheets.Count 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "shrinktofit"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).ShrinkToFit)
Next j
Next i
Else
rv = -(rng.ShrinkToFit)
End If
Case "stylename"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Style.Name
Next j
Next i
Else
rv = rng.Style.Name
End If
Case "text" 'USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Text
Next j
Next i
Else
rv = rng.Text
End If
Case "textcolor" 'from later 123 versions - USEFUL!
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Font.ColorIndex
Next j
Next i
Else
rv = rng.Font.ColorIndex
End If
Case "top"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Top
Next j
Next i
Else
rv = rng.Top
End If
Case "topborder" 'from later 123 versions
'Note: many possible return values! wrap inside SIGN to test T/F
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeTop).LineStyle - _
xlLineStyleNone
Next j
Next i
Else
rv = rng.Borders(xlEdgeTop).LineStyle - xlLineStyleNone
End If
Case "topbordercolor" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Borders(xlEdgeTop).ColorIndex
Next j
Next i
Else
rv = rng.Borders(xlEdgeTop).ColorIndex
End If
Case "underline" 'from later 123 versions - USEFUL!
'Note: many possible return values! wrap inside SIGN to test T/F
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).Font.Underline - _
xlUnderlineStyleNone
Next j
Next i
Else
rv = rng.Font.Underline - xlUnderlineStyleNone
End If
Case "usedrange" 'NOTE: returns Range addresses!
t = ws.UsedRange.Address 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "usestandardheight"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).UseStandardHeight)
Next j
Next i
Else
rv = -(rng.UseStandardHeight)
End If
Case "usestandardwidth"
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).UseStandardWidth)
Next j
Next i
Else
rv = -(rng.UseStandardWidth)
End If
Case "valign", "verticalalignment" 'from later 123 versions
'Note: different return values than 123. 0 = Bottom-aligned
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = _
rng.Cells(i, j).VerticalAlignment - _
xlVAlignBottom
Next j
Next i
Else
rv = rng.VerticalAlignment - xlVAlignBottom
End If
Case "visible", "sheetvisible", "worksheetvisible"
t = -(ws.Visible) 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "width", "columnwidth" 'from CELL
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = rng.Cells(i, j).Width
Next j
Next i
Else
rv = rng.Width
End If
Case "workbookfullname" 'same as FileName in later 123 versions
t = wb.FullName 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "workbookname"
t = wb.Name 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "workbookpath"
t = wb.Path 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
Case "wrap", "wraptext" 'from later 123 versions
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = -(rng.Cells(i, j).WrapText)
Next j
Next i
Else
rv = -(rng.WrapText)
End If
Case Else 'invalid property/characteristic
t = CVErr(xlErrValue) 'invariant
If rar Then
For i = 1 To m
For j = 1 To n
rv(i, j) = t
Next j
Next i
Else
rv = t
End If
End Select
ExtCell = rv
End Function
End Function should be the last line, now open a new workbook,
press Alt + F11, click insert>module and paste in what you copied
press Alt + Q to close the VBE, now do file>save as, from dropdown in the
save as type list at the very bottom where it says Microsoft excel add-in
(or something similar)
file type is (*.xla). In the file name box type ExtCell and click OK to save
it.
Now look under tools>add-ins and see if it is there, if it is check mark it.
If you don't see it you can close and open excel and then check it.
Now use a help column for your filter (remove the filter first), assume the
coloured cells are
in column A, in the help column use
=extcell("backgroundcolor",A1)
copy down and you'll get a different number for each colour, apply the
filter and filter on the different numbers
the numbers are interior colorindex. If you look at the different built in
function they are pretty self
explanatory Look for each case and the string that is within quotes and use
it like
=extcell("string",cell_ref)
--
No private emails please, for everyone's
benefit keep the discussion in the newsgroup.
Regards,
Peo Sjoblom
