Summary: Learn about the increased worksheet capacity in Microsoft Office Excel 2007 and techniques that you can use as you design and create worksheets to improve calculation performance. (40 printed pages)
Charles Williams, Decision Models Limited
October 2006
Applies to: Microsoft Office Excel 2007, Microsoft Office Excel 2003, Microsoft Excel 2002, Microsoft Excel 2000
Contents
=REPLACE(LEFT(CELL("filename",A2),FIND("]",CELL("filename",A2))-5),1,FIND("[",CELL("filename",A2)),"")or possibly better
=MID(CELL("filename"),SEARCH("[",CELL("filename"))+1,SEARCH("]",CELL("filename"))-5-SEARCH("[",CELL("filename")))
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = True
End Sub
=CELL("row")=ROW()
"Excel's AutoFilter feature definitely ranks right up there when it comes to handy tools. This feature, which you access with the Data, Filter, AutoFilter command, works with a range of cells set up as a database or list. When AutoFiltering is turned on, the row headers display drop-down arrows that let you specify criteria (such as "Age greater than 30"). Rows that don't match your criteria are hidden, but they are redisplayed when you turn off AutoFiltering.
'One problem with AutoFiltering is that you can't tell which criteria are in effect. Stephen Bullen developed a custom VBA worksheet function that displays the current AutoFilter criteria in a cell. The instructions that follow are for Excel 97 or later.
'Press Alt+F11 and insert a new module for the active workbook. Then enter the VBA code for the FilterCriteria shown below.
Function FilterCriteria(Rng As Range) As String
'By Stephen Bullen
Dim Filter As String
Filter = ""
On Error GoTo Finish
With Rng.Parent.AutoFilter
If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Finish
Filter = .Criteria1
Select Case .Operator
Case xlAnd
Filter = Filter & " AND " & .Criteria2
Case xlOr
Filter = Filter & " OR " & .Criteria2
End Select
End With
End With
Finish:
FilterCriteria = Filter
End Function
'After you've entered the VBA code, you can use the function in your formulas. The single-cell argument for the FilterCriteria function can refer to any cell within the column of interest. The formula will return the current AutoFilter criteria (if any) for the specified column. When you turn AutoFiltering off, the formulas don't display anything.
'The figure below shows the FilterCriteria in action. The function is used in the cells in row 1. For example, cell A1 contains this formula:
=FilterCriteria(A3)
'As you can see, the list is currently filtered to show rows in which column A contains January, column C contains a code of A or B, and column D contains a value greater than 125 (column B is not filtered, so the formula in cell B1 displays nothing). The rows that don't match these criteria are hidden."
Function FilterOn(myCell As Range) As Boolean
On Error Resume Next
With myCell.Parent.AutoFilter
With .Filters(myCell.Column - .Range.Column + 1)
If .On Then FilterOn = True
End With
End With
End Function
"This month I thought I would show you the ConvertFormula method! This method allows us to change a range of formulas from Absolute to Relative, Relative to Absolute, Relative Row to Absolute Row and so on... In fact we can change any relative or absolute aspect of any formula. The Excel help for the ConvertFormula is written as below:
'Converts cell references in a formula between the A1 and R1C1 reference styles, between relative and absolute references, or both.
expression.ConvertFormula(Formula, FromReferenceStyle, ToReferenceStyle, ToAbsolute, RelativeTo)
expression Required. An expression that returns an Application object.
Formula Required Variant. A string that contains the formula you want to convert. This must be a valid formula, and it must begin with an equal sign.
FromReferenceStyle Required Long. The reference style of the formula. Can be one of the following XLReferenceStyle constants: xlA1 or xlR1C1.
ToReferenceStyle Optional Variant. The reference style you want returned. Can be one of the following XLReferenceStyle constants: xlA1 or xlR1C1. If this argument is omitted, the reference style isn't changed; the formula stays in the style specified by FromReferenceStyle.
ToAbsolute Optional Variant. Specifies the converted reference type. Can be one of the following XLReferenceType constants: xlAbsolute, xlAbsRowRelColumn, xlRelRowAbsColumn, or xlRelative. If this argument is omitted, the reference type isn't changed.
RelativeTo Optional Variant. A Range object that contains one cell. Relative references relate to this cell.
Sub MakeAbsoluteorRelative()
'Written by OzGrid Business Applications
'www.ozgrid.com
Dim RdoRange As Range
Dim i As Integer
Dim Reply As String'Ask whether Relative or Absolute
Reply = InputBox("Change formulas to?" & Chr(13) & Chr(13) _
& "Relative row/Absolute column = 1" & Chr(13) _
& "Absolute row/Relative column = 2" & Chr(13) _
& "Absolute all = 3" & Chr(13) _
& "Relative all = 4", "OzGrid Business Applications")'They cancelled
If Reply = "" Then Exit Sub
On Error Resume Next
'Set Range variable to formula cells only
Set RdoRange = Selection.SpecialCells(Type:=xlFormulas)'determine the change type
Select Case Reply
Case 1 'Relative row/Absolute column
For i = 1 To RdoRange.Areas.Count
RdoRange.Areas(i).Formula = _
Application.ConvertFormula _
(Formula:=RdoRange.Areas(i).Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, ToAbsolute:=xlRelRowAbsColumn)
Next i
Case 2 'Absolute row/Relative column
For i = 1 To RdoRange.Areas.Count
RdoRange.Areas(i).Formula = _
Application.ConvertFormula _
(Formula:=RdoRange.Areas(i).Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsRowRelColumn)
Next i
Case 3 'Absolute all
For i = 1 To RdoRange.Areas.Count
RdoRange.Areas(i).Formula = _
Application.ConvertFormula _
(Formula:=RdoRange.Areas(i).Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute)
Next i
Case 4 'Relative all
For i = 1 To RdoRange.Areas.Count
RdoRange.Areas(i).Formula = _
Application.ConvertFormula _
(Formula:=RdoRange.Areas(i).Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, ToAbsolute:=xlRelative)
Next i
Case Else 'Typo
MsgBox "Change type not recognised!", vbCritical, _
"OzGrid Business Applications"
End Select
'Clear memory
Set RdoRange = Nothing
End Sub
Sub AddComment()
On Error Resume Next
Dim cmtMsg As String, nwLne As String, LneCnt As Long, Dscn As Long
If TypeName(Selection) <> "Range" Then Exit Sub
AddLine:
nwLne = InputBox("Enter line " & LneCnt + 1 & " of your comment text." & vbNewLine & vbNewLine & _
"Leave blank or push Cancel to exit.", "Please write your comment")
If LneCnt > 0 Then cmtMsg = cmtMsg & Chr(10) & nwLne Else cmtMsg = nwLne
LneCnt = LneCnt + 1
If nwLne = "" Then
Exit Sub
Else
Dscn = MsgBox("Do you want to add another line? " & vbNewLine & vbNewLine _
& "Push No to insert the comment.", vbYesNo, "Add another line?")
If Dscn = vbYes Then GoTo AddLine
Application.ScreenUpdating = False
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True
.Shape.AutoShapeType = msoShapeRoundedRectangle
.Shape.Shadow.Visible = msoFalse
.Shape.Select True
.Text Text:=cmtMsg
With Selection.ShapeRange
.Shadow.Visible = msoFalse
.ScaleHeight 0.3, msoFalse, msoScaleFromTopLeft
.Adjustments.Item(1) = 0.25
End With
.Shape.TextFrame.Autosize = True
Dscn = MsgBox("Do you want the comment to remain visible? ", _
vbYesNo, "Keep comment visible?")
If Dscn = vbNo Then .Visible = False
End With
.Select
End With
Application.ScreenUpdating = True
End If
End Sub
Sub SplashscreenShape()
Dim Ctr As Long
ThisWorkbook.Sheets("Sheet3").Activate
Range("A1:R41").Select
ActiveWindow.Zoom = True
Do While Ctr < 5
ActiveSheet.Shapes("Message").Select
Select Case Ctr
Case 0
Selection.Characters.Text = "CHANGE" & Chr(10) & "IT" & Chr(10) & "A" & Chr(10) & "BIT"
Case 1
Selection.Characters.Text = "WRITE" & Chr(10) & "ANYTHING" & Chr(10) & "YOU" & Chr(10) & "LIKE"
Case 2
Selection.Characters.Text = "DO" & Chr(10) & "IT" & Chr(10) & "FOR" & Chr(10) & "FUN"
Case 3
Selection.Characters.Text = "THIS" & Chr(10) & "IS" & Chr(10) & "THE" & Chr(10) & "END"
End Select
Ctr = Ctr + 1
Application.Wait Now + TimeSerial(0, 0, 2)
Loop
Application.ScreenUpdating = False
ActiveSheet.Shapes("Message").Select
Selection.Characters.Text = "PUT" & Chr(10) & "SOME" & Chr(10) & "TEXT" & Chr(10) & "HERE"
Range("IV65536").Select
ThisWorkbook.Sheets("Sheet1").Select
Application.ScreenUpdating = True
End Sub
Sub Auto_Open()
SplashscreenShape
End Sub
Sub Auto_Close()
ThisWorkbook.Close SaveChanges:=False
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = True
End Sub
=CELL("address")=ADDRESS(ROW(),COLUMN())
=OR(CELL("row")=ROW(), CELL("col")=COLUMN())
=OR(AND(CELL("row")=ROW(),CELL("col")+1>COLUMN()),AND(CELL("col")=COLUMN(),CELL("row")+1>ROW()))
Sub BarGraphsInCells()
On Error Resume Next
Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
Set theRange = Selection
LoopCount = 1
For Each Cell In theRange
BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.7 ' Adjust to suit
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
Select
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = 12
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Transparency = 0.8
.Name = "The Bars" & LoopCount
End With
ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
Selection.ShapeRange.Group.Select
Selection.Name = "The Bars"
Cell.Offset(1).Select
LoopCount = LoopCount + 1
Next
theRange.Select
End Sub
Sub BarGraphsInCells2()
On Error Resume Next
Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
Set theRange = Selection
LoopCount = 1
For Each Cell In theRange
BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Transparency = 0.8
.ShapeRange.Fill.ForeColor.SchemeColor = 48
.ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
.Name = "The Bars" & LoopCount
End With
ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
Selection.ShapeRange.Group.Select
Selection.Name = "The Bars"
Cell.Offset(1).Select
LoopCount = LoopCount + 1
Next
theRange.Select
End Sub
Sub BarGraphsInCells3()
On Error Resume Next
Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
Set theRange = Selection
LoopCount = 1
For Each Cell In theRange
If Not CBool(Application.Rank(Cell, theRange) <= 5) Then GoTo NextStep
BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Transparency = 0.8
.ShapeRange.Fill.ForeColor.SchemeColor = 10 'change the color here!
.ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
.Name = "The Bars" & LoopCount
End With
NextStep:
ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
Selection.ShapeRange.Group.Select
Selection.Name = "The Bars"
Cell.Offset(1).Select
LoopCount = LoopCount + 1
Next
theRange.Select
End Sub
Sub BarGraphsInCells4()
On Error Resume Next
Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
Set theRange = Selection
LoopCount = 1
For Each Cell In theRange
BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9 ' Adjust width
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Offset(1).Top - 1.5, BarWidth, 1.5). _
Select
With Selection
.ShapeRange.Line.Visible = msoFalse ' remove to show lines
.ShapeRange.Fill.ForeColor.SchemeColor = 48 ' change color to suit
.ShapeRange.Fill.BackColor.SchemeColor = 11 'remove for a single color, change color to suit
.ShapeRange.Fill.TwoColorGradient msoGradientVertical, 1 'remove for no gradient
.ShapeRange.Height = 2
.Name = "The Bars" & LoopCount
End With
NextStep:
ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
Selection.ShapeRange.Group.Select
Selection.Name = "The Bars"
Cell.Offset(1).Select
LoopCount = LoopCount + 1
Next
theRange.Select
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Not Intersect(ActiveCell, Range("MyRange")) Is Nothing Then
Shapes("The Bars").Delete
Range("MyRange").Select
BarGraphsInCells4
Target.Select
End If
Application.ScreenUpdating = True
End Sub
Public XL As New ShowDrive
Private Sub Auto_Open()
Set XL.App = Application
End Sub
Public WithEvents App As Excel.Application
Private Sub App_WorkbookOpen(ByVal Wb As Excel.Workbook)
On Error Resume Next
If Wb.Name <> "PERSONAL.XLS" Then _
ActiveWindow.Caption = Left(Wb.FullName, 2) & " " & Wb.Name
End Sub
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
On Error Resume Next
If Len(Application.Substitute(Sh.Parent.Name, ".xls", "")) <> Len(Sh.Parent.Name) Then _
ActiveWindow.Caption = Left(Sh.Parent.FullName, 2) & " " & Sh.Parent.Name
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = False Then
If MsgBox("Do you really want to save this Workbook? ", vbYesNo) = vbNo Then
Cancel = True
Exit Sub
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Cells(1, 1) = False Then Exit Sub
With Target
If .Column = 2 And _
.Row > 2 And _
.Row < ActiveSheet.UsedRange.Row + _
ActiveSheet.UsedRange.Rows.Count Then
.EntireColumn.Validation.Delete
With .Validation
.Add Type:=xlValidateInputOnly
.InputTitle = "" ' Optional
.InputMessage = "Customer: " & Cells(Target.Row, 2) & Chr(10) & _
"Invoice Number: " & Cells(Target.Row, 14) & Chr(10) & _
"Item Ordered: " & Cells(Target.Row, 6) & Chr(10) & _
"Quantity: " & Format(Cells(Target.Row, 12), "#,##0") & Chr(10) & _
"Amount: " & Format(Cells(Target.Row, 16), "$ #,##0.00") & Chr(10) & _
"Total Sales: " & Format(Application.Sum(Range("TotalSales")), "$ #,##0.00")
End With
End If
End With
End Sub
=ODD(ROW())=ROW()
=EVEN(ROW())=ROW()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A1") = False Then Exit Sub ' Optional
On Error Resume Next
Dim myRange As Range
Dim myTopLeftCell As Range
Dim myBottomRightCell As Range
' Set your Top Left Cell and Bottom Right Cell, (Range Names can be used also)
' ****************************************************************
Set myTopLeftCell = Range("B2")
Set myBottomRightCell = Range("H20")
' ****************************************************************
If Target.Row >= myTopLeftCell.Row And _
Target.Offset(Selection.Rows.Count - 1).Row <= myBottomRightCell.Row And _ Target.Column >= myTopLeftCell.Column And _
Target.Offset(, Selection.Columns.Count - 1).Column <= myBottomRightCell.Column Then Set myRange = Selection If ActiveSheet.Shapes("hSelection") Is Nothing Then ActiveSheet.Shapes.AddShape(msoShapeRectangle, myTopLeftCell.Left, Selection.Top, _ myBottomRightCell.Offset(, 1).Left - _ myTopLeftCell.Left, Selection.Height).Select With Selection With .ShapeRange .Fill.Visible = msoFalse .Line.ForeColor.SchemeColor = 12 ' Change Color Here .Line.Weight = 2.25 ' Change Line Weight (Thickness) Here .ZOrder msoSendToBack .Shadow.Visible = msoFalse End With .Name = "hSelection" .PrintObject = False End With Else With ActiveSheet.Shapes("hSelection") .Left = myTopLeftCell.Left .Top = Selection.Top .Width = myBottomRightCell.Offset(, 1).Left - myTopLeftCell.Left .Height = Selection.Height .ShapeRange.Shadow.Visible = msoFalse End With End If myRange.Select End If Set myTopLeftCell = Nothing Set myBottomRightCell = Nothing Set myRange = Nothing End Sub
Sub AddCheckbox()
On Error Resume Next
ActiveSheet.CheckBoxes.Add(0, 0, 0, 0).Select
With Selection
.Characters.Text = ""
.Value = xlOn
.LinkedCell = "A1"
End With
Range("A1").Select
Selection.Font.ColorIndex = 2
End Sub
Function AutoFilter_Criteria(Header As Range) As String
Dim strCri1 As
String, strCri2 As String
Application.Volatile
With
Header.Parent.AutoFilter
With .Filters(Header.Column - .Range.Column + 1)
If Not .On Then Exit Function
strCri1 = .Criteria1
If .Operator =
xlAnd Then
strCri2 = " AND " & .Criteria2
ElseIf .Operator = xlOr
Then
strCri2 = " OR " & .Criteria2
End If
End With
End With
AutoFilter_Criteria = _
UCase(Header) & ": " & strCri1 &
strCri2
End Function
Private Sub Worksheet_Calculate()
Dim lFilt As Long, lFiltArrows As Long
Dim lFiltRow As Long
On Error Resume Next
Application.EnableEvents =
False
lFiltRow = Me.AutoFilter.Range.Row
lFiltArrows =
Me.AutoFilter.Filters.Count
Range(Cells(lFiltRow, 1), Cells(lFiltRow, _
lFiltArrows)).Interior.ColorIndex = xlNone
If Me.FilterMode = True Then
For lFilt = 1 To lFiltArrows
If Me.AutoFilter.Filters.Item(lFilt).On
Then
Cells(lFiltRow, lFilt).Interior.ColorIndex = 46
End If
Next
lFilt
End If
Application.EnableEvents = True
On Error GoTo 0
End
Sub
