Issue No. 20 (July 8, 2001)
**********************************
COMMENTS
Welcome to the 20th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE used to be a monthly publication. It's been a long
time since the last issue, and I cannot say when the next issue
will be.
Feel free to distribute copies of EEE to your friends and colleagues and
to contribute your Excel gems to EEE so that others can benefit from your
work.
All issues are available for download from the EEE web page located on
John Walkenbach's web site.
Due to problems associated with distribution lists, I cannot mail EEE
directly to individuals anymore. Look for the latest issue at:
http://www.j-walk.com/ss/excel/eee/index.htm
**********************************
Top Excel Sites
See:
http://home.pacbell.net/beban
for a great collection of array UDFs.
**********************************
POWER FORMULA TECHNIQUES
by David Hager
---How can I find the count of unique items in a filtered column?---
Define a column range in your table (excluding header) as Rge.
Define unRge as:
=IF(SUBTOTAL(3,OFFSET(Rge,ROW(Rge)-MIN(ROW(Rge)),,1)),Rge,"")
Then, the array formula to return the # of unique occurrences in a filtered
column is:
=SUM(N(IF(ISNA(MATCH("",unRge,0)),MATCH(Rge,Rge,0),IF(MATCH(unRge,unRge,0)
=MATCH("",unRge,0),0,MATCH(unRge,unRge,0)))=ROW(Rge)-MIN(ROW(Rge))+1))
by Tom Ogilvy
---How can I set validation so no spaces are allowed?---
Select A1:C20 with A1 as the active cell in the selection.
Pick Data=>Validation from the menu and select the custom option.
Use the following formula:
=LEN(A1)=LEN(SUBSTITUTE(A1," ",""))
Since you are using relative cell references, the validation formula will
adjust to address each of the cells in the selection.
by John Walkenbach and John Green
---How can I locate cells containing formulas with literal values?---
Use the following UDF as your conditional formatting formula.
Function CellUsesLiteralValue(Cell As Range) As Boolean
If Not Cell.HasFormula Then
CellUsesLiteralValue = False
Else
CellUsesLiteralValue = Cell.Formula Like "*[=^/*+-/()><, ]#*"
End If
End Function
It accepts a single cell as an argument. It returns True if the cell's
formula contains an operator followed by a numerical digit. In other words,
it identifies cells that have a formula which contains a literal numeric
value.
You can test each cell in the range, and highlight it if the function
returns True.
by George Simms
---If the NETWORKDAYS function (found in the Analysis Toolpak) cannot be used,
is there a formula that will perform the same function?---
If the Start date is in A1 and the End date is in B1, then use:
=(INT(B1/7)-INT(A1/7))*5+MAX(0,MOD(B1,7)-1)-MAX(0,MOD(A1,7)-2)
**********************************
VBA CODE EXAMPLES
by Bill Manville
---The objective is to prevent people cutting/copying and pasting when your
workbook is open.---
Run DisableCutAndPaste from a suitable event procedure
(e.g. Workbook_Open or Worksheet_Activate) and EnableCutAndPaste
from another (e.g. Workbook_Close or Worksheet_Deactivate).
Sub DisableCutAndPaste()
EnableControl 21, False ' cut
EnableControl 19, False ' copy
EnableControl 22, False ' paste
EnableControl 755, False ' pastespecial
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "+{DEL}", ""
Application.OnKey "+{INSERT}", ""
Application.CellDragAndDrop = False
End Sub
Sub EnableCutAndPaste()
EnableControl 21, True ' cut
EnableControl 19, True ' copy
EnableControl 22, True ' paste
EnableControl 755, True ' pastespecial
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "+{DEL}"
Application.OnKey "+{INSERT}"
Application.CellDragAndDrop = True
End Sub
Sub EnableControl(Id As Integer, Enabled As Boolean)
Dim CB As CommandBar
Dim C As CommandBarControl
For Each CB In Application.CommandBars
Set C = CB.FindControl(Id:=Id, recursive:=True)
If Not C Is Nothing Then C.Enabled = Enabled
Next
End Sub
by Chip Pearson
---Is is possible to disable certain menu items on both the toolbar and the
right-click pop-up that wil prevent the user from either deleteing/renaming,
a sheet without protecting the entire workbook structure?---
You can disable them with:
Dim Ctrl As Office.CommandBarControl
For Each Ctrl In Application.CommandBars.FindControls(ID:=847)
Ctrl.Enabled = False
Next Ctrl
For Each Ctrl In Application.CommandBars.FindControls(ID:=889)
Ctrl.Enabled = False
Next Ctrl
by Chip Pearson
---How can I search through all the cell formulas on a worksheet and find out
the cells that reference a specific named range?---
Use the following procedure:
Dim Rng As Range
Dim NameRange As Range
Set NameRange = ActiveWorkbook.Names("TheName").RefersToRange
On Error Resume Next
For Each Rng In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
Err.Clear
If Not Application.Intersect(Rng.DirectPrecedents, NameRange) Is Nothing
Then
If Err.Number = 0 Then
Debug.Print "Cell: " & Rng.Address & " refers to " &
NameRange.Address
End If
End If
Next Rng
**********************************
POWER PROGRAMMING TECHNIQUE
by Jim Rech
---Can I change the Excel logo to something else?---
This code shows you how to change the Excel icon:
Declare Function GetActiveWindow32 Lib "USER32" Alias _
"GetActiveWindow" () As Integer
Declare Function SendMessage32 Lib "USER32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function ExtractIcon32 Lib "SHELL32.DLL" Alias _
"ExtractIconA" (ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long
Sub ChangeXLIcon()
Dim h32NewIcon As Long
Dim h32WndXLMAIN As Long
h32NewIcon = ExtractIcon32(0, "Notepad.exe", 0)
h32WndXLMAIN = GetActiveWindow32()
SendMessage32 h32WndXLMAIN, &H80, 1, h32NewIcon 'Icon big
SendMessage32 h32WndXLMAIN, &H80, 0, h32NewIcon 'Icon small
End Sub
by Leo Heuser
---I would like to create a Excel template which when you open a document
from it, it assigns a unique sequential number to the new document.
Is there a way of doing this?---
Below find two routines to do, what you want. They are both
inserted in "ThisWorkbook" () for the template and
are fired, when a new invoice is created.
The first one saves the current invoice number to the registry,
and can be used, if you are the sole user of the system. The
second solution saves the number in an INI-file, which you can
place, where you please. This solution is useful, if more persons
are using the invoice system.
Private Sub Workbook_Open()
'leo.heuser@get2net.dk June/October 2000
'From the template, in the VBA editor, set a reference to
'Microsoft Visual Basic for Applications Extensibility 5.3
'in the menu Tools
Dim WorksheetName As String
Dim WorksheetCell As String
Dim SettingName As String
Dim lLine As Long
Dim InvoiceNumber As Variant
Dim InvoiceNumberCell As Object
Dim TemplateName As String
TemplateName = "John.xlt"
WorksheetName = "Invoice"
WorksheetCell = "F7"
SettingName = "John"
Set InvoiceNumberCell = Worksheets(WorksheetName).Range(WorksheetCell)
If UCase(ActiveWorkbook.Name) = UCase(TemplateName) Then GoTo Finito
InvoiceNumber = GetSetting(SettingName, WorksheetName, "InvoiceNumber")
If InvoiceNumber = "" Then
InvoiceNumber = 1
Else
InvoiceNumber = InvoiceNumber + 1
End If
SaveSetting SettingName, WorksheetName, "InvoiceNumber", InvoiceNumber
InvoiceNumberCell.Value = InvoiceNumber
With
ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.CodeName).CodeModule
lLine = .ProcBodyLine("Workbook_Open", vbext_pk_Proc)
.InsertLines lLine + 1, "Exit Sub"
End With
Finito:
Set InvoiceNumberCell = Nothing
End Sub
________________________________________________________
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As
String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As String, ByVal lpString As Any, ByVal lpFileName As String) As
Long
Private Sub Workbook_Open()
'leo.heuser@get2net.dk June 2000
'From the template, in the VBA editor, set a reference to
'Microsoft Visual Basic for Applications Extensibility 5.3
'in the menu Tools
Dim WorksheetName As String
Dim WorksheetCell As String
Dim Section As String
Dim kKey As String
Dim lLine As Long
Dim InvoiceNumber As Long
Dim InvoiceNumberCell As Object
Dim TemplateName As String
Dim IniFileName As String
Dim Dummy As Variant
TemplateName = "John2.xlt"
WorksheetName = "Invoice"
WorksheetCell = "F7"
Section = "Invoice"
kKey = "Number"
IniFileName = "C:\Windows\Temp\InvoiceNumber.txt"
Set InvoiceNumberCell = Worksheets(WorksheetName).Range(WorksheetCell)
If UCase(ActiveWorkbook.Name) = UCase(TemplateName) Then GoTo Finito
Dummy = GetString(Section, kKey, IniFileName)
If Left(Dummy, 1) = Chr$(0) Then
InvoiceNumber = 1
Else
InvoiceNumber = CLng(Dummy) + 1
End If
WritePrivateProfileString Section, kKey, CStr(InvoiceNumber),
IniFileName
InvoiceNumberCell.Value = InvoiceNumber
With
ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.CodeName).CodeModule
lLine = .ProcBodyLine("Workbook_Open", vbext_pk_Proc)
.InsertLines lLine + 1, "Exit Sub"
End With
Finito:
Set InvoiceNumberCell = Nothing
End Sub
Function GetString(Section As String, Key As String, File As String) As
String
Dim KeyValue As String
Dim Characters As Long
KeyValue = String(255, 0)
Characters = GetPrivateProfileString(Section, Key, "", KeyValue, 255,
File)
If Characters > 1 Then
KeyValue = Left(KeyValue, Characters)
End If
GetString = KeyValue
End Function
by Jim Rech
---Is there a way to delete all name ranges in a selection at one time?---
Be careful to not break references to other formulas when using this
procedure.
Sub Dename()
Dim Cell As Range
ActiveSheet.TransitionFormEntry = True
For Each Cell In Selection.SpecialCells(xlFormulas)
Cell.Formula = Cell.Formula
Next
ActiveSheet.TransitionFormEntry = False
End Sub
**********************************
DEVELOPER TIPS
by Chip Pearson
---Notes on an interesting and useful debugging technique.---
Suppose you are developing some application, and you have some global
variable such as:
Public NumberOfUnits As Long
In your app, the only reasonable value for this is, say, between 1 and 100.
For debugging purposes, you can "trap" your errors, when you assign an
invalid value to this, as follows.
In your standard code module (NOTE: This does NOT have to be in a class
module!) do the following:
Dim p_NumberOfUnits As Long
Property Get NumberOfUnits() As Long
NumberOfUnits = p_NumberOfUnits
End Property
Property Let NumberOfUnits(Value As Long)
If (Value >=1 ) And (Value <=100) Then
p_NumberOfUnits = Value
Else
Err.Raise 5
End If
End Property
Then, in the rest of your code, you'd access the variable in the normal way:
Sub AAA()
NumberOfUnits = 10
NumberOfUnits = 123
Msgbox "Units: " & NumberOfUnits
End Sub
These standard access methods will indeed take you through the get/let/set
property procedures. And yes, standard code modules (BAS files) do support
Property Get/Let/Set procedures. You're code will blow up on the statement
NumberOfUnits = 123
(You must raise an error. The specific error is, of course, you choice.)
Then, just use the View Call Stack to see where you called this from. Of
course, this adds some overhead, so in the production version of the code,
you'd remove the Property Get/Let pair, and rename
Dim p_NumberOfUnits As Long
to
Dim NumberOfUnits As Long
Or, of course, you could do everything with conditional compilation.
In the end, the really interesting thing is that you can use property
get/let/set procedures in a standard code module, not just in a class
module.
**********************************
Issue No.20 OF EEE (PUBLISHED 09Jul2001)
Next issue scheduled for [UNKNOWN]
BY David Hager
dchager@compuserve.com
**********************************
Issue No. 19 (June 1, 2000)
********************************** COMMENTS Welcome to the 19th issue of the Excel Experts E-letter (or EEE), by David Hager. EEE is normally a monthly publication. Feel free to distribute copies of EEE to your friends and colleagues and to contribute your Excel gems to EEE so that others can benefit from your work. Back issues are available for download from the EEE web page located on John Walkenbach's web site. New issues are normally available on the 1st of each month. There will be periods when EEE is not published due to time and travel constraints. http://www.j-walk.com/ss/excel/eee/index.htm ********************************** Top Excel Sites See: http://www.officevba.com for VBA articles and downloadables files of the highest order. ********************************** POWER FORMULA TECHNIQUES by Leo Heuser and Eero TibarHow can you get a list of unique entries in an n * m array by using a worksheet formula? Example: Assuming data in B5 : GR10, enter this array formula in e.g. G12. G11 must be empty or, if it has a value, this value must not occur in B5 : GR10. =OFFSET($B$5,MIN(IF(COUNTIF($G$11:G11,$B$5:$GR$10)=0,ROW($B$5:$GR$10)- ROW($B$5))),MOD(MIN(IF(COUNTIF($G$11:G11,$B$5:$GR$10)=0,ROW($B$5:$GR$10)- ROW($B$5) +(COLUMN($B$5:$GR$10)-COLUMN($B$5))/1000)),1)*1000) Drag down until the value in G12 begins repeating. Here is slightly different approach to extract unique items from a N*M table (named as "tbl" in the formula). Type "Unique items from the table" in A1 and enter the following formula as an array into A2 and copy it down. =INDEX(tbl,MIN(IF(COUNTIF($A$1:A1,tbl)=0,ROW(tbl)-MIN(ROW(tbl))+1)), MATCH(0,COUNTIF($A$1:A1,INDEX(tbl,MIN(IF(COUNTIF($A$1:A1,tbl)=0,ROW(tbl) -MIN(ROW(tbl))+1)),,1)),0),1) ********************************** VBA CODE EXAMPLES by David Hager I like using the Pick List feature in Excel 97 (and later), but I don't like having to select the menu item for that feature everytime I go to a new cell. How can I solve this problem? Place this event procedure in the ThisWorkbook module. Then, any time you select a cell where the pick list would pop up when called from a menu item, it will instead pop up automatically. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target _ As Excel.Range) On Error Resume Next With Target If .Value <> "" Then Exit Sub If .Row = 1 Or .Row = 65536 Then Exit Sub If .Offset(-1, 0).Value = "" And .Offset(1, 0).Value = "" Then _ Exit Sub If Selection.Address <> .Address Then Exit Sub End With Application.EnableEvents = False SendKeys "+{F10}k" Application.EnableEvents = True End Sub by Bob Umlas How can you give users a Print Preview and not allow them to change any of thesettings? Use the following procedure. It disables key buttons at the top of the preview window. Sub PrtPvw() ActiveSheet.PrintPreview False '"False"==> no changes allowed ActiveWindow.View = xlNormalView ' In case user switched to Page Brake Preview. End Sub by Bob Umlas How can I step through a For-Next loop by using a custom step process? If you need to loop through code with an index which takes on specific values like 1,4,5,18,28,33,34,85 instead of the more commom 1,2,3,4,5,6.. or 1,3,5,7,..., then you can use this technique: Sub OddLoop() For i = 1 to 8 j=Array(1,4,5,18,28,33,34,85)(i) 'Now use j as your subscript Next End Sub ********************************** POWER PROGRAMMING TECHNIQUE by Bob Umlas This procedure contains VBA code to add to your existing VBA code -- basically, it puts one statement at the beginning of each procedure in every module (class modules and event procedures not included). This statement is a call to a routine (which YOU need to write) and passes the sub/function name. For example... Before: Sub ABC() Dim i as Integer For each x in sheets Next End Sub Sub xyz() End Sub After: Sub ABC() MyProc "ABC" Dim i as Integer For each x in sheets Next End Sub Sub xyz() MyProc "xyz" End Sub Notice that afterwards, there's a new line immediately after the sub. It calls MyProc (this is changeable) and passes the name of the procedure it's in. You can use MyProc to trace flow, track the time, etc -- you can get creative here! There are 2 main routines: Addit, and Deleteit. Running Addit will insert the one-liner, running Deleteit will remove this one-liner. The code is inserted into the active workbook. The first line inside the VBE for AddALine.xls is: Public Const TheProcName As String = "MyProc" '============CHANGE THIS LINE and whatever you change "MyProc" to will be the routine called inside each procedure of your code. Public Const TheProcName As String = "MyProc" '===============CHANGE THIS LINE Sub Addit() '=========================== 'RUN THIS CODE TO INSERT THE LINE INTO THE ACTIVE WORKBOOK's CODE '=========================== AddALine MsgBox "Done....Don't forget to write procedure " & _ TheProcName & "!", vbExclamation End Sub Sub Deleteit() '=========================== 'RUN THIS CODE TO DELETE THE LINE '=========================== DelALine MsgBox TheProcName & " has been deleted from each procedure." End Sub Sub AddALine() Dim ProcName As String, ProcNames() As String, Boo As Boolean Dim LngR As Long, TheLine As Long, LngI As Long Set VBP = ActiveWorkbook.VBProject nocomponents = VBP.VBComponents.Count On Error Resume Next For i = 1 To nocomponents If VBP.VBComponents(i).Type = 1 Then 'module With VBP.VBComponents(i).CodeModule If .Name = "ModInserter" Then GoTo NextOne col = .CountOfLines codl = .CountOfDeclarationLines ProcName = .ProcOfLine(codl + 1, LngR) If ProcName = "" Then GoTo NextOne If LngR <> 0 Then GoTo NextOne TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc) thetext = .Lines(TheLine, 1) If Right(thetext, 1) = "_" Then j = 2 Else j = 1 .InsertLines TheLine + j, TheProcName & """" & _ ProcName & """" LngI = codl + 1 col = col + 1 2: If LngI > col Then GoTo 1 If ProcName <> .ProcOfLine(LngI, LngR) Then ProcName = .ProcOfLine(LngI, LngR) If LngR <> 0 Then GoTo 3 TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc) thetext = .Lines(TheLine, 1) If Right(thetext, 1) = "_" Then j = 2 Else j = 1 .InsertLines TheLine + j, TheProcName & """" & _ ProcName & """" col = col + 1 End If 3: LngI = LngI + 1 GoTo 2 1: End With End If NextOne: Next End Sub Sub DelALine() Dim ProcName As String, ProcNames() As String, Boo As Boolean Dim LngR As Long, TheLine As Integer, LngI As Integer If MsgBox("Are you sure you want to delete " & TheProcName & _ " from each procedure?", vbYesNo + vbQuestion) = vbNo Then Exit Sub Set VBP = ActiveWorkbook.VBProject nocomponents = VBP.VBComponents.Count On Error Resume Next For i = 1 To nocomponents If VBP.VBComponents(i).Type = 1 Then 'module With VBP.VBComponents(i).CodeModule If .Name = "ModInserter" Then GoTo NextOne col = .CountOfLines codl = .CountOfDeclarationLines ProcName = .ProcOfLine(codl + 1, LngR) If ProcName = "" Then GoTo NextOne If LngR <> 0 Then GoTo NextOne TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc) thetext = .Lines(TheLine, 1) If Right(thetext, 1) = "_" Then j = 2 Else j = 1 If Left(.Lines(TheLine + j, 1), 5) <> Left(TheProcName, 5) Then ' MsgBox TheProcName & " not found in procedure """ & _ ProcName & """... ignoring" GoTo 22 End If .DeleteLines TheLine + j, 1 22: LngI = codl + 1 2: If LngI > col Then GoTo 1 If ProcName <> .ProcOfLine(LngI, LngR) Then ProcName = .ProcOfLine(LngI, LngR) If LngR <> 0 Then GoTo 3 If ProcName = "" Then GoTo 3 TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc) thetext = .Lines(TheLine, 1) If Right(thetext, 1) = "_" Then j = 2 Else j = 1 If Left(.Lines(TheLine + j, 1), 5) <> _ Left(TheProcName, 5) Then ' MsgBox TheProcName & " not found in procedure """ & _ ProcName & """... ignoring" GoTo 3 End If .DeleteLines TheLine + j, 1 End If 3: LngI = LngI + 1 GoTo 2 1: End With End If NextOne: Next End Sub Sub Showcode() MsgBox "Before running ""Addit"", activate the workbook whose code " & _ "this routine will update." MsgBox "Change ""TheProcName"" to the name of the procedure you want " & _ "to run for each sub." Application.SendKeys "{up}{up}" Application.Goto "Addit" End Sub ********************************** DEVELOPER TIPS by Chip Pearson and Stephen Bullen Why use class modules? Basically, a Class is the definition of an Object. The word "object" is deliberately vague. And object is anything that you want to design. It is defined entirely (mostly) by its properties, methods, and events. In Excel, there are hundreds of "built-in" objects, all defined by class modules. The "class" is the definition of an "object". For example, a Worksheet is an object. And there is a class module which defines just what a Worksheet really is. There are various properties of a Worksheet object (e.g., Visible). Properties simply define and set various attributes. Think of properties as "Adjectives" which describe an object. An object also has Methods. Methods are the "Verbs" of objects. For example, a Worksheet object has an Activate method. This causes something to happen. Finally there are Events. I can't think of a good grammatical analogy for events. Essentially, Events are how an object tells the rest of the world that something happened. For example, in a Worksheet object, there is a Change event. This is the Worksheet object's way of telling the rest of world, "Hey, look at me, I changed". The rest of the world can ignore that event, or it may take action. But the world has been told that object has done something (or had done something to it). Now, you use Class Modules to create your own objects. Suppose you were writing an application that was used for employee tracking. Using a class module, you would define your own object called "Employee". This class would define a single, generic, employee. With the DIM and SET statement, you can create a specific employee, based on the "template" or "definition" of a generic employee. The Employee class would have several Properties, such as Name, Address, and Salary. It could also have methods, such as Promote, GiveRaise, and Fire. In your application, the Promote method would do the same things -- e.g., increasing the Salary property, updating a central database, sending an email to another department to buy him a nicer computer, etc. These actions are all the same whenever you Promote any employee. By using a Class Module to define a "generic" employee, you only have to write the code once. Then to work with a *specific* employee, you just call the methods for that employee: Dim ThisEmp As CEmployee ' more code Set ThisEmp = New CEmployee ThisEmp.Name = "John Smith" ' more code ThisEmp.Promote All of the code related to the Promote event is contained in the Class modules (the definition of any employee), so you can simply call the Promote method. Once you've defined the Class, you never have to worry about what Promote actually does. Here's another way to think about it. In the Worksheet object, there is a PrintOut method. Within the PrintOut method, there is all the code that actually formats the worksheet for printing, determines what printer you have, and actually does all the work of printing the sheet. As a VBA programmer, you don't have to worry about any of that. You simply call PrintOut, and let that do all the work for you. You don't have to worry about what sort of printer the user has, whether it can print color, and a hundred other things. You just call PrintOut and let the Object do all the work. Class Modules let you create you own objects, or extend the functionality of other, existing objects. They are very useful because they allow you to write the code once, and then simply create new objects based on the class (think of it like a blueprint for a house). It is write the code once, and use it many times. For example, I have a class module that extends the functionality of a standard list box. The standard list box doesn't have a MoveUp method, which simply moves the selected item one row up in the list. By using a Class Module, I added a MoveUp method (as well as MoveDown, MoveToTop, MoveToBottom, etc). I wrote that class one time. Now, whenever I need to use "better" list boxes in my applications, I just use that Class. I don't have to "re-invent the wheel" for every application I write. This just scratches the surface of what a Class is and how to use them. If you've ever heard the term "object oriented", Classes are the foundation of this entire design philosophy. Just to provide the opposite end of the spectrum to Chip's excellent answer, class modules can also be though of as user-defined types (UDT) on steroids. A simple UDT can be used to store related information about a particular thing, such as Chip's employee: Type Employee Name As String DOB As String Grade As String Salary As Double End Type If you wanted to do stuff with an employee, you'd use a normal procedure somewhere: Sub RaiseEmployee(uEmp As Employee, sNewGrade As String) 'Validate Grade '... uEmp.Grade = sNew Grade 'Do stuff to work out new salary etc. '... End Sub Sub FireEmployee(uEmp As Employee) uEmp.Grade = "F" uEmp.Salary = 0 End Sub Sub SetSalary(uEmp As Employee, dNewSalary As Double) 'Validate Salary '... 'Does new salary mean a new grade? '... End Sub etc. That's fine as far as it goes and you can create some great programs without ever using class modules. The main thing wrong with it is that the *data* for the object (i.e. the contents of your UDT) is separated from the *actions* that are performed on the data (the RaiseEmployee and FireEmployee subs). Hence, you have to be very careful that the same validation is performed in each sub and that one sub doesn't alter the data in a way that will cause another sub to fail; this is often the cause of some of the hardest bugs to find - logic problems. If you use a class module instead, you can include the validation and other functionality *with* the data; to the extent that the data can *not* be changed unless it's valid. You can think of it as that the 'Grade' property of the Employee (for example) can validate *itself* and can refuse to be updated, or it can know *itself* that when it changes to a valid new grade, it needs to change the salary too. In the example above, with two simple procedures, think what would happen if we had to add another check before changing the grade, or introduce a new action to be performed if the grade is changed (such as notifying their manager). In the procedural approach, we'd have to change two or three routines to handle it - i.e. wherever the grade is set. In the clas module approach, it is simply another action to be performed by the 'grade' property *itself* - none of the other code needs to know about it. i.e: Dim msGrade As String 'Data that only code in the class can 'see' 'Property to read the grade Public Property Get Grade() As String: Grade = msGrade: End property 'Property to set the grade Public Property Let Grade(sNew As String) If Not sNew Is Valid Then Err.Raise "Not a valid grade" Exit Property End If 'Grade is valid, so we can safely store it msGrade = sNew 'Now what else do we need to do when the grade changes? Select Case sNew Case "F" 'Being fired, better ask for a redundancy slip Salary = 0 Case "M" 'Being made a manager, better ask for a better car 'Increase the Salary too Case "D" 'Being demoted, schedule for more frequent reviews 'Decrease the Salary 'etc End Select End Property Public Sub Fire() Grade = "F" End Sub Now, everything that needs to be done when the grade is changed has been made an *integral* part of changing the grade - there's no way that the grade can be changed by anywhere else in the system without those checks and actions happening. Really, though, it just boils down to a different design and development style, and one that hopefully takes us further down the road of improved code reuse, more stability and fewer opportunities for bugs to creep in. The hardest thing to work out, though, is to decide which functionality should be 'in' the class module and which should be on the outside, but using the class module. For example, do we have a '.Fire' method within the class, or a Fire(oEmp As Employee) procedure outside that just sets the grade to "F"? I find that I'm using class modules more and more; it's almost at the stage where if I'm asked "Why use a class module", my reply is "Why not?" ********************************** Issue No.19 OF EEE (PUBLISHED 31May2000) Next issue scheduled for 05July2000. BY David Hager dchager@compuserve.com **********************************
Issue No. 18 (April 1, 2000)
********************************** COMMENTS Welcome to the 18th issue of the Excel Experts E-letter (or EEE), by David Hager. EEE is now a monthly publication. Feel free to distribute copies of EEE to your friends and colleagues and to contribute your Excel gems to EEE so that others can benefit from your work. Back issues are available for download from the EEE web page located on John Walkenbach's web site. New issues are normally available on the 1st of each month. There will be periods when EEE is not published due to time and travel constraints. http://www.j-walk.com/ss/excel/eee/index.htm IMPORTANT NOTE!!! I have just discovered that my mailing list has suffered from tremendous problems. A significant number of people on the list have been receiving multiple copies of EEE and over 100 people have been somehow kicked off of the list over a period of months. The software I am using to manage the list is old and obviously contains bugs I was not aware of. I have put in a significant amount of time to try to correct this problem. I apologize to all of the people that have not been receiving EEE. I hope that this fix solves the problem. ********************************** Top Excel Sites For a list of fixed problems in Microsoft Office 2000 Service Release 1 (SR-1), go to: http://support.microsoft.com/support/kb/articles/q245/0/21.ASP ********************************** WORKSHEET FORMULA TIPS by Bernie DeitrickI have a formula =COUNTIF('Sheet1'!Ddd2346, "=0") in a cell, where Ddd2346 refers to a named range. What I would like to do is to have an easy way to copy this formula down a column of cells, and have the Ddd2346 number increment by one each time. The next cell needs to be Ddd2347, then Ddd2348 etc. In this specific case, use: =COUNTIF(INDIRECT("Ddd"&2345+ROW(A1)),"=0") When this formula is filled down the column, the numeric suffixes of the named ranges increment by one. ********************************** POWER FORMULA/FUNCTION TECHNIQUES by George Simms I have the following problem: In cells A1:E1: 1, 2, 3, 4, 5 In cells A2:E2: 6, 7, 8, 9, 10 In cells A5:E5: 21, 22, 23, 24, 25 Now I want to total diagonally (A1, B2, C3, D4 and E5) and I do that by the formula: =SUM((ROW(A1:A5)=COLUMN(A1:E1))*(A1:E5)) - array entered. This works fine (sum =65), but I wondered how can I total diagonally "the other way" (here A5, B4, C3, D2 and E1)? To sum A5:E1 diagonally, use: =SUM(N(OFFSET(E1,ROW(1:5)-1,-1*ROW(1:5)+1))) Or (not Array Entered): =SUMPRODUCT(N(OFFSET(E1,ROW(INDIRECT("1:5"))-1,-1*ROW(INDIRECT("1:5"))+1))) It would be better to use ROW(INDIRECT("1:5") in all the formulas, like =SUM(N(OFFSET(E1,ROW(INDIRECT("1:5"))-1,-1*ROW(INDIRECT("1:5"))+1))) as inserting a row above row 5 will change the reference. To sum across sheets (Sheet1!A1 Sheet2!B2 Sheet3!C3..etc) use: =SUM(N(INDIRECT("Sheet"&ROW(1:5)&"!"&ADDRESS(ROW(1:5),ROW(1:5))))) Or (not Array Entered): =SUMPRODUCT(N(INDIRECT("Sheet"&ROW(1:5)&"!"&ADDRESS(ROW(1:5),ROW(1:5))))) ********************************** VBA CODE EXAMPLES by Tom Ogilvy and Dana DeLouis I'd like to expand the Custom Autofilter to 3 or more entries. This procedure assumes you want to display cells that have a,b, and c in the Cell in column A. If you are looking for multiple "Or" conditions, then use Union instead of Intersect. Sub MultCustomAutoFilter() Dim rng1 As Range Dim rng2 As Range Dim rngAll3 As Range Range("A1").AutoFilter With [_FilterDatabase].Offset(1, 0) Range("A1").AutoFilter Field:=1, Criteria1:="*a*", Operator:=xlAnd, _ Criteria2:="*b*" Set rng1 = .SpecialCells(xlVisible) Range("A1").AutoFilter Field:=1, Criteria1:="*c*" Set rng2 = .SpecialCells(xlVisible) ActiveSheet.AutoFilterMode = False Set rngAll3 = Application.Intersect(rng1, rng2) .EntireRow.Hidden = True rngAll3.EntireRow.Hidden = False End With End Sub This procedure works for Excel 2000. For prior version change the range object in the With statement to: ActiveSheet.AutoFilter.Range.Offset(1, 0) by Bill Manville Is there a way to reliably code the show detail and hide detail commands off of the "Data" menu into a VB macro? This feature is not well supported by VBA. Thus, to hide the detail for the block within which the cursor sits, use: ExecuteExcel4Macro "SHOW.DETAIL(1," & ActiveCell.Row & ",FALSE)" by Stephen Bullen How can I change the name of the vbcomponent based on the name of the related worksheet? The CodeName of a sheet can be changed with: Sub RenameCodeName(oWks As Sheet, sNewName As String) oWks.Parent.VBProject.vbComponents(oWks.CodeName) _ .Properties("_CodeName") = sNewName End Sub ********************************** POWER PROGRAMMING TECHNIQUE by Bill Manville I have to check the contents of a large spreadsheet against a second more up to date spreadsheet in another workbook. The structure of the 2 workbooks is the same. How can I identify which cells differ so I can investigate those individually. This procedure creates a new workbook which lists the comparison results for each worksheet in the two workbooks of interest. Each of the two workbooks should be open prior to running this procedure. Replace the dummy names in the the DoCompare sub with appropriate filenames. Sub DoCompare() Dim WS As Worksheet Workbooks.Add For Each WS In WorkBooks("SomeBook.xls").Worksheets CompareSheets WS, Workbooks("SomeOther.xls").Worksheets(WS.Name) Next End Sub Sub CompareSheets(WS1 As Worksheet, WS2 As Worksheet) Dim iRow As Integer, iCol As Integer Dim R1 As Range, R2 As Range Worksheets.Add.Name = WS1.Name ' new book for the results Range("A1:D1").Value = Array("Address", "Difference", WS1.Parent.Name, WS2.Parent.Name) Range("A2").Select For iRow = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Row, _ WS2.Range("A1").SpecialCells(xlLastCell).Row) For iCol = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Column, _ WS2.Range("A1").SpecialCells(xlLastCell).Column) Set R1 = WS1.Cells(iRow, iCol) Set R2 = WS2.Cells(iRow, iCol) ' compare the types to avoid getting VBA type mismatch errors. If TypeName(R1.Value) <> TypeName(R2.Value) Then NoteError R1.Address, "Type", R1.Value, R2.Value ElseIf R1.Value <> R2.Value Then If TypeName(R1.Value) = "Double" Then If Abs(R1.Value - R2.Value) > R1.Value * 10 ^ (-12) Then NoteError R1.Address, "Double", R1.Value, R2.Value End If Else NoteError R1.Address, "Value", R1.Value, R2.Value End If End If ' record formulae without leading "=" to avoid them being evaluated If R1.HasFormula Then If R2.HasFormula Then If R1.Formula <> R2.Formula Then NoteError R1.Address, "Formula", Mid(R1.Formula, 2), Mid(R2.Formula, 2) End If Else NoteError R1.Address, "Formula", Mid(R1.Formula, 2), "**no formula**" End If Else If R2.HasFormula Then NoteError R1.Address, "Formula", "**no formula**", Mid(R2.Formula, 2) End If End If If R1.NumberFormat <> R2.NumberFormat Then NoteError R1.Address, "NumberFormat", R1.NumberFormat, R2.NumberFormat End If Next iCol Next iRow With ActiveSheet.UsedRange.Columns .AutoFit .HorizontalAlignment = xlLeft End With End Sub Sub NoteError(Address As String, What As String, V1, V2) ActiveCell.Resize(1, 4).Value = Array(Address, What, V1, V2) ActiveCell.Offset(1, 0).Select If ActiveCell.Row = Rows.Count Then MsgBox "Too many differences", vbExclamation End End If End Sub ********************************** EXCEL TIPS by John Green I need a simple macro to take the cell text in a selected cell(s) and add characters such as "." after the text until the cell is filled to its width. You get something like: Text_here..... and................ here.............. All you need to do is apply a custom format (Format|Cells - Number) to the cell such as: @*. @ is a place marker for the text and the character after the asterisk is repeated to fill the cell. "*.@" fills to the left. If you want to do this in code: Range("A1:A10").NumberFormat = "@*." Note: If this is done with cells containing numbers, they cannot be operated on as numbers since they are formatted as text. As a workaround to this problem, use: =SUM(VALUE(range)) ' array-entered instead of =SUM(range) by George Simms The problem I have is that in order to add a value to an existing value field I need to insert an "=" at the beginning of the cell before it displays the solution. If I simply type the "+" or "-" after the value Excel displays the formula (obviously interpreting it as text). Can I perform this task without inserting the "=" each time? There is a way to do what you want, if you use it to only edit your data. From the menu > Tools > Options >Transition tab> check the "Transition formula entry" box. It is recommend that once you have edited the data, go back and uncheck the box. If left checked this can produce some odd results, entering dates etc..... ********************************** Issue No.18 OF EEE (PUBLISHED 01Apr2000) Next issue scheduled for 01May2000. BY David Hager dchager@compuserve.com **********************************
Issue No. 17 (March 1, 2000)
**********************************
COMMENTS
Welcome to the 17th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE is now a monthly publication. Feel free to distribute
copies of EEE to your friends and colleagues and to contribute your Excel
gems to EEE so that others can benefit from your work.
Back issues are available for download from the EEE web page located on
John Walkenbach's web site. New issues are normally available on the 1st
of each month. There will be periods when EEE is not published due to time
and travel constraints.
http://www.j-walk.com/ss/excel/eee/index.htm
**********************************
Top Excel Sites
Go to this site for a great index of Excel information.
http://www.mathtools.net/Excel/index.html
**********************************
WEB INFORMATION ON:
ExecuteExcel4Macro method
Access to closed workbooks:
http://eva.dc.lsoft.com/scripts/wa.exe?A2=ind9908D&L=excel-l&P=R8921&m=28403
http://eva.dc.lsoft.com/scripts/wa.exe?A2=ind9812C&L=excel-l&P=R8589&m=28403
http://x43.deja.com/=dnc/getdoc.xp?AN=370019007&CONTEXT=936234727.222691395&hitnum=103
http://x30.deja.com/=dnc/getdoc.xp?AN=394587442&CONTEXT=936236165.1461321770&hitnum=69
Excel charts:
http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9810B&L=excel-g&P=R5489
http://x30.deja.com/=dnc/getdoc.xp?AN=497422618&CONTEXT=936236165.1461321770&hitnum=37
http://x43.deja.com/=dnc/getdoc.xp?AN=362117773&CONTEXT=936234727.222691395&hitnum=121
http://x43.deja.com/=dnc/getdoc.xp?AN=247283361&CONTEXT=936234727.222691395&hitnum=187
Printing:
http://x43.deja.com/=dnc/getdoc.xp?AN=240180079&CONTEXT=936234727.222691395&hitnum=191
http://x43.deja.com/=dnc/getdoc.xp?AN=296331018&CONTEXT=936234727.222691395&hitnum=160
http://support.microsoft.com/support/kb/articles/Q139/4/05.asp
Formula.Find:
http://www.mailbase.ac.uk/lists/excel-vb-discuss/1999-03/0001.html
Custom Views:
http://eva.dc.lsoft.com/scripts/wa.exe?A2=ind9606&L=excel-l&P=R8426
http://eva.dc.lsoft.com/scripts/wa.exe?A2=ind9606&L=excel-l&P=R8508
Delete Rows:
http://x30.deja.com/=dnc/getdoc.xp?AN=484149794&CONTEXT=936236165.1461321770&hitnum=97
Set.Update.Status
http://support.microsoft.com/support/kb/articles/Q108/3/84.asp
Close:
http://x43.deja.com/=dnc/getdoc.xp?AN=209988463&CONTEXT=936234727.222691395&hitnum=202
ShowBar:
http://x43.deja.com/=dnc/getdoc.xp?AN=364967596&CONTEXT=936234727.222691395&hitnum=120
**********************************
WORKSHEET FORMULA TIP
by Harlan Grove
Question from Microsoft Excel worksheet formula newsgroup:
> Is there a formula that I could use to count the number
> of rows that contain data based on my criteria..
...
> Using this data as an example
>
> A B C D E F
> 1 3 5 8 12 13
> 3 2 6 5 7 9
> 5 7 4 8 12 3
>
>I would like to identify how many times 3 and 5 appear together
>and I might even want to identify how many times 3, 5 and 12
>appear together.
>From the above example data you can see that the numbers
>3, 5 and 12 wont always be in the same column, using
>DCOUNT restricts me to identifying the column heading in my
>field criteria.
...
>My criteria my look like this
>
>Column headings----> Find 1 Find 2 Find 3 Find 4 Find 5 Find 6
>and I would enter----> 3 5 12
>the formula / function -> whatever it is that would do what I require
>would return a count on the number of rows that contain 3,5 and 12
>any order
...
Answer:
With your sample data range named MyData and the 'criteria' entry cells
(all 6) range above named MyCrit, try this array formula.
=COUNT(IF(MMULT(COUNTIF(MyCrit,MyData),
TRANSPOSE(COLUMN(MyData)^0))=COUNT(MyCrit),1))
Note: this assumes no duplicate 'criteria' entries.
**********************************
POWER FORMULA/FUNCTION TECHNIQUES
by David Hager
I wrote this array formula to combine the functionality of the XIRR and MIRR
functions. This formula returns the internal rate of return for a schedule
of cash flows that is not necessarily periodic while considering both the
cost of the investment and the interest received on reinvestment of cash.
The fields used in the formula are defined below.
=POWER((SUM(IF(values>0,values*(POWER(1+rRate,(MAX(dates)-dates)/daybase))
,0)))/(SUM(IF(values<0,values/(POWER(1+iRate,(MAX(dates)-dates)/daybase))
,0)))*-1,1/((MAX(dates)-MIN(dates))/daybase))-1
where:
values is the row or column range of cashflows
dates is the row or column range of corresponding dates
iRate is the interest rate you pay on the money used in the cash flows
rRate is the interest rate you receive on the cash flows as you reinvest them
daybase is days-in-year basis to use (usually 360 or 365).
The following UDF provides the same functionality as the array formula.
Function XMIRR(TheValues As Range, TheDates As Range, iRate, rRate, daybase)
Dim rCount As Integer
Dim cCount As Integer
Dim rCounter As Integer
Dim cCounter As Integer
Dim TheVal As Double
Dim TheDate As Double
Dim MaxDate As Double
Dim MinDate As Double
Dim PosSum As Double
Dim NegSum As Double
On Error GoTo eFunction
rCount = TheValues.Rows.Count
cCount = TheValues.Columns.Count
PosSum = 0
NegSum = 0
MinDate = TheDates.Offset(0, 0).Resize(1, 1).Value
If rCount > cCount Then
MaxDate = TheDates.Offset(rCount - 1, 0).Resize(1, 1).Value
For rCounter = 0 To rCount - 1
TheVal = TheValues.Offset(rCounter, 0).Resize(1, 1).Value
TheDate = TheDates.Offset(rCounter, 0).Resize(1, 1).Value
If TheVal < 0 Then
NegSum = NegSum + TheVal / ((1 + iRate) ^ ((TheDate - _
MinDate) / daybase))
Else
PosSum = PosSum + TheVal * ((1 + rRate) ^ ((MaxDate - _
TheDate) / daybase))
End If
Next
Else
MaxDate = TheDates.Offset(0, cCount - 1).Resize(1, 1).Value
For cCounter = 0 To cCount - 1
TheVal = TheValues.Offset(0, cCounter).Resize(1, 1).Value
TheDate = TheDates.Offset(0, cCounter).Resize(1, 1).Value
If TheVal < 0 Then
NegSum = NegSum + TheVal / ((1 + iRate) ^ ((TheDate - _
MinDate) / daybase))
Else
PosSum = PosSum + TheVal * ((1 + rRate) ^ ((MaxDate - _
TheDate) / daybase))
End If
Next
End If
XMIRR = ((PosSum / NegSum * -1) ^ (1 / ((MaxDate - MinDate) / _
daybase))) - 1
Exit Function
eFunction:
XMIRR = CVErr(2015)
End Function
by Laurent Longre
This VB function returns the same result as Excel's WEEKNUM function.
Function WKNUM(D As Date) As Long
D = Int(D)
WKNUM = DateSerial(Year(D + (8 - WeekDay(D)) Mod 7 - 3), 1, 1)
WKNUM = ((D - WKNUM - 3 + (WeekDay(WKNUM) + 1) Mod 7)) \ 7 + 1
End Function
**********************************
VBA CODE EXAMPLES
by Jim Rech
This procedure changes the font size in all cell comments on a worksheet.
Sub ChgAllComments()
Dim Cell As Range
For Each Cell In Cells.SpecialCells(xlCellTypeComments)
With Cell.Comment.Shape.TextFrame.Characters.Font
.Size = 9
End With
Next
End Sub
by Stephen Bullen
This procedure open shows Excel's DataForm in New Record mode.
Sub ShowDataFormWithNewRecord()
'Send a keystroke
SendKeys "+{TAB 6} "
'This is the same as ActiveSheet.ShowDataForm,
'but without the International Issues
CommandBars.FindControl(Id:=860).Execute
End Sub
**********************************
EXCEL DEVELOPER'S TIPS
Pull in correct values from Internet:
When importing stock data into a sheet using a web query, fractional stock
prices less than 1 may be interpreted by Excel as dates. However, selecting
Tools, Options, Transition and then clicking "Transition formula entry"
coerces Excel into accepting the desired value.
Use class modules from another project:
By John Green
You can create an instance of a class in another project by creating a
function in the referenced project containing the class module. In the
project containing the class module, include something like the following
code, in a standard module:
Function GetClass() As Class1
Set GetClass = New Class1
End Function
In the project that wants to access the class, use something like the
following code:
Dim cls As Object
Sub Test()
Set cls = GetClass()
End Sub
**********************************
Issue No.17 OF EEE (PUBLISHED 01Mar2000)
Next issue scheduled for 01Apr2000.
BY David Hager
dchager@compuserve.com
**********************************
Issue No. 16 (January 31, 2000)
**********************************
COMMENTS
Welcome to the 16th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE is now a monthly publication. Feel free to distribute
copies of EEE to your friends and colleagues.
Back issues are available for download from the EEE web page located on
John Walkenbach's web site. New issues are normally available on the 1st
of each month. There will be periods when EEE is not published due to time
and travel constraints.
http://www.j-walk.com/ss/excel/eee/index.htm
Note: The index for issues 11-15 is at the end of this E-letter.
**********************************
TOP EXCEL WEB SITES
Visit Chip Pearson's growing and everchanging Excel web site at:
http://www.cpearson.com
A new addition to his site are two interesting Excel games
(free with unprotected source code) made by yours truly.
http://www.cpearson.com/excel/games.htm
This web page provides a wealth of diverse Excel information.
http://www.mathtools.net/Excel/index.html
**********************************
WORKSHEET FORMULA TIP
by Harlan Grove
Needed: A formula to determine if the items contained in Range1 are
contained in Range2. If not, then a comparison of Range1 will be made
to another range and so on. For example:
Range1:
A B C
PEAR APPLE ORANGE
Range2:
A B C D
PEAR APPLE ORANGE BANANA
To check if everything in Range1 appears in Range2, you could use this
array formula:
=AND(NOT(ISNA(MATCH(Range1,Range2,0))))
Trickier: if all single row ranges to check Range1 against are collected
into a single table, for example, Range 3 as
pear mango orange
pear mango grapes banana dates
pear grapes orange banana
grapes mango orange banana
pear apple grapes banana dates figs
apple pear orange banana
grapes apple orange banana
pear apple orange banana dates figs cheries
then the following array function will return the row index of the first
(topmost) row in which there's a match for all entries in Range1:
=MATCH(COLUMNS(Range1),MMULT(COUNTIF(Range1,Range3),
TRANSPOSE(COLUMN(Range3)^0)),0)
which takes advantage of COUNTIF's peculiar semantics when both of its
arguments are arrays. This formula returns 6.
**********************************
POWER FORMULA TECHNIQUE
by David Hager
This array formula returns TRUE if the number in cell A1 is a Fibonacci
number. A Fibonacci number is a member of the number series 1,1,2,3,5,8
13,21,34,55,89,... which is intimately linked to a variety of growth
and life processes.
=OR(A1=ROUND((((SQRT(5)+1)/2)^ROW(1:73))/SQRT(5),0))
by Harlan Grove
This formula is a general two dimensional array reshaping formula for an
array of size NewRows x NewCols, similar to APL's RHO array, that works
for any worksheet array A.
=N(OFFSET(A,MOD(INT(((ROW(INDIRECT("1:"&NewRows))-1)*NewCols+
TRANSPOSE(ROW(INDIRECT("1:"&NewCols))-1))/COLUMNS(A)),
ROWS(A)),MOD(((ROW(INDIRECT("1:"&NewRows))-1)*NewCols+
TRANSPOSE(ROW(INDIRECT("1:"&NewCols))-1)),COLUMNS(A)),1,1))
For example, if A is {11,12;21,22;31,32;41,42;51,52;61,62}, NewRows has
value 5 and NewCols has value 3, this formula gives
{11,12,21;22,31,32;41,42,51;52,61,62;11,12,21}.
**********************************
VBA CODE EXAMPLES
by David Hager
Use the first function to read a range from a closed workbook into an
array and the second procedure for direct input into a range on the
active worksheet.
'CWRIA is short for ClosedWorkbookRangeIntoArray
Function CWRIA(fPath As String, fName As String, sName As String, _
rng As String)
Dim sRow As Integer
Dim sColumn As Integer
Dim sRows As Integer
Dim sColumns As Integer
Dim vrow As Integer
Dim vcol As Integer
Dim fpStr As String
Dim cArr()
On Error GoTo NoArr
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & fName) = "" Then
CWA = CVErr(xlErrValue)
Exit Function
End If
sRow = Range(rng).Row
sColumn = Range(rng).Column
sRows = Range(rng).Rows.Count
sColumns = Range(rng).Columns.Count
ReDim cArr(sRows, sColumns)
For vrow = 1 To sRows
For vcol = 1 To sColumns
fpStr = "'" & fPath & "[" & fName & "]" & sName & "'!" & _
"r" & sRow + vrow - 1 & "c" & sColumn + vcol - 1
cArr(vrow, vcol) = ExecuteExcel4Macro(fpStr)
Next
Next
CWRIA = cArr
Exit Function
NoArr:
CWRIA = CVErr(xlErrValue)
End Function
'CWRIR is short for ClosedWorkbookRangeIntoArray
Sub CWRIR(fPath As String, fName As String, sName As String, _
rng As String, destRngUpperLeftCell As String )
Dim sRow As Integer
Dim sColumn As Integer
Dim sRows As Integer
Dim sColumns As Integer
Dim vrow As Integer
Dim vcol As Integer
Dim fpStr As String
Dim cArr()
On Error GoTo NoArr
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & fName) = "" Then
CWA = CVErr(xlErrValue)
Exit Function
End If
sRow = Range(rng).Row
sColumn = Range(rng).Column
sRows = Range(rng).Rows.Count
sColumns = Range(rng).Columns.Count
ReDim cArr(sRows, sColumns)
Set destRange = ActiveSheet.Range(destRngUpperLeftCell)
For vrow = 1 To sRows
For vcol = 1 To sColumns
fpStr = "'" & fPath & "[" & fName & "]" & sName & "'!" & _
"r" & sRow + vrow - 1 & "c" & sColumn + vcol - 1
destRange.Offset(vrow - 1, vcol - 1) = ExecuteExcel4Macro(fpStr)
Next
Next
NoArr:
End Sub
The following procedure copies the values from the range A1:C3 from Sheet1 of
the closed workbook cellDataVal.xls located at D:\EXCEL97\xlformulas to the
range F9:H11 on the active worksheet.
Sub InsertRangeFromClosedWorkbook()
CWRIR "D:\EXCEL97\xlformulas", "cellDataVal.xls", "Sheet1", _
"a1:c3", "f9"
End Sub
**********************************
POWER PROGRAMMING TECHNIQUES
by xxxxxx
Here is a method for counting instances of Excel application and storing
the handles for each instance in an array.
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA"(ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow"(ByVal
hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA"(ByVal
hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Const GW_HWNDNEXT = 2
Sub xlInstances()
Dim hwnd As Long, lRet As Long
Dim hWndArray() As Long
Dim i As Integer
Dim sClassBuffer As String
i = 0
hwnd = FindWindow("XLMAIN", vbNullString)
If hwnd <> 0 Then
ReDim hWndArray(i)
hWndArray(i) = hwnd
Do
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
If hwnd = 0 Then Exit Sub
sClassBuffer = String(255, 0)
lRet = GetClassName(hwnd, sClassBuffer, Len(sClassBuffer))
sClassBuffer = Left(sClassBuffer, InStr(1, sClassBuffer, Chr(0),
vbTextCompare) - 1)
If UCase(sClassBuffer) = "XLMAIN" Then
i = i + 1
ReDim Preserve hWndArray(i)
hWndArray(i) = hwnd
End If
Loop
End If
End Sub
Keep the Array hWndArray global, so that you can access it outside the search
function. The handle is valid as long as the instance exists and will die if
you quit Excel.
by Tom Ogilvy and David Braden
A FAST method for building an unique list from data in column A.
Sub BuildUnique1()
Dim vArr As Variant
Dim vArr1 As Variant
Set RNG = Range(Cells(1, "A"), Cells(1, "A"). End(xlDown))
vArr = Application.Transpose(RNG)
ShellSort vArr
ReDim vArr1(1 To 1)
vArr1(1) = vArr(1)
j = 1
For i = LBound(vArr, 1) + 1 To UBound(vArr, 1)
If vArr(i) <> vArr1(j) Then
j = j + 1
ReDim Preserve vArr1(1 To j)
vArr1(j) = vArr(i)
End If
Next
End Sub
Using David Braden's implementation of ShellSort:
Sub ShellSort(list As Variant, Optional ByVal LowIndex As Variant, Optional
HiIndex As Variant)
'Translation of Shell's Sort as described in
' "Numerical Recipes in C", 2nd edition, Press et al.
'For large arrays, consider Quicksort. This algorithm is at least
'as good up to about 100 or so elements. But with 500 randomized
'elements it is about 27% slower than QSort, and looks
'increasingly worse as the array size increases.
'Dec 17, '98 - David J. Braden
Dim i As Long, j As Long, inc As Long
Dim var As Variant
If IsMissing(LowIndex) Then LowIndex = LBound(list)
If IsMissing(HiIndex) Then HiIndex = UBound(list)
inc = 1
Do While inc <= HiIndex - LowIndex: inc = 3 * inc + 1: Loop
Do
inc = inc \ 3
For i = LowIndex + inc To HiIndex
var = list(i)
j = i
Do While list(j - inc) > var
list(j) = list(j - inc)
j = j - inc
If j <= inc Then Exit Do
Loop
list(j) = var
Next
Loop While inc > 1
End Sub
by Laurent Longre
VBA code for placing a shortcut on the desktop.
Declare Function SHGetSpecialFolderLocation Lib "Shell32" _
(ByVal hwnd As Long, ByVal nFolder As Long, ppidl As Long) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Declare Function SetWindowPos Lib "User32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal uFlags As Long) As Long
Declare Function SetForegroundWindow Lib "User32" _
(ByVal hwnd As Long) As Long
Declare Function GetForegroundWindow Lib "User32" () As Long
Function ShortCut(Target As String, _
Optional Target_Type As Long) As Boolean
Dim hwnd As Long
Dim Pidl As Long
Dim Bureau As String
If Dir(Target & IIf(Target_Type = vbDirectory, "\", ""), _
Target_Type) = "" Then Exit Function
SHGetSpecialFolderLocation 0, 0, Pidl
Bureau = Space(260)
SHGetPathFromIDList Pidl, Bureau
Bureau = Left(Bureau, InStr(1, Bureau, vbNullChar) - 1)
hwnd = GetForegroundWindow
SetWindowPos hwnd, -1, 0, 0, 0, 0, 3
Shell "RunDLL32 AppWiz.Cpl,NewLinkHere " & Bureau & "\"
SendKeys """" & Target & """~~", True
SetForegroundWindow hwnd
ShortCut = True
End Function
Sub Test()
' Creates a shortcut to the directory "C:\Temp"
MsgBox IIf(ShortCut("C:\Temp", vbDirectory), _
"Shortcut created", "Can't find the directory")
' Creates a shortcut to the file "C:\Temp\Zaza.xls"
MsgBox IIf(ShortCut("C:\Temp\Zaza.xls"), _
"Shortcut created", "Can't find the file")
End Sub
**********************************
EXCEL DEVELOPER'S TIP
by Jim Rech
How to duplicate your VBE setup.
So you've got your new PC and you've copied over your Excel.xlb and
Personal.xls from the old machine. Now you go into the VBE and... oh yeah,
how do you copy over your VBE preferences, customizations and toolbars?
Here's how:
- Run RedEdit.exe
- Navigate to the key HKEY_CURRENT_USER\Software\Microsoft\VBA\6.0\Common
for Office 2000 or HKEY_CURRENT_USER\Software\Microsoft\VBA\Office for
Office 97.
- From the file menu pick Export Registry File and select a file name.
- Copy the resulting REG file to the new machine.
- On the new machine you can run RegEdit and pick Import Registry File or
from Windows Explorer right click on the file and select Merge.
**********************************
Issue No.16 OF EEE (PUBLISHED 01Feb2000)
Next issue scheduled for 01Mar2000.
BY David Hager
dchager@compuserve.com
**********************************
CUMULATIVE INDEX (ISSSUES 11-15):
WORKSHEET FORMULAS:
Issue #11:
-case-sensitive MATCH function
-extract the phone number as text in form of 123-45678
-'bankers rounding' for a number to given number of significant digits.
Issue #12:
-reverse lookup formula with max value
Issue #13:
-using defined name formulas for creating a versatile consolidation
workbook that works without any programming [DOWNLOAD EXAMPLE FILE]
Issue #14:
Issue #15:
-reverses the sequence of elements in a range
-returns TRUE if number is a prime number
VBA PROCEDURES:
Issue #11:
-selects the real last used cell in a worksheet
-function returns the dimension order of an array (up to 4D)
-brings data into a worksheet from an external source using ADO
-prints (in the Immediate window) the same list of files displayed
by the Edit-Links menu command
-displays the chart wizard dialog box
-adjusts the row height of a merged cell with wrap text set
-returns the named ranges that include the active cell
-searches through all worksheets in a workbook
Issue #12:
-procedure for the filling of formulas across worksheets to obtain
sheet-relative formulas
-converts normal formulas to those that show an empty cell
if an error condition exists in the original formula
Issue #13:
Issue #14:
-series of boolean functions associated with filtered lists
-procedure delinks all of the charts in a workbook
-opens an application through the use of the Shell function and it
allows for the lag time involved with the opening process
-procedure removes all code and related structures from a workbook
-generalized procedures for converting data to a normalized form
-event procedures to place the contents of a cell into a cell comment
when another entry is made
Issue #15:
-reads the names of all sheets in a closed workbook using ADO
-groups multiple worksheets and print a selection from the selected
sheets all on one page
-general function for evaluate and replace using comparisons
-assigns a procedure to the Click event of a command button added to
a form at run time
-adds an Add-In path dynamically while the add-in is loading
-finds all of the user-defined custom number formats in a workbook
TIPS AND TECHNIQUES:
Issue #11:
-list of web sites for products that will find/remove passwords
-workaround to formatting problems associated with merged cells
-quick way to freeze formulas to values on a worksheet
-using the UserInterfaceOnly argument of the Protect method
Issue #12:
-use defined names in a workbook that are defined in another workbook
-URL for David McRitchie's Excel web site
Issue #13:
Issue #14:
-URL for Rob Bovey's Excel web site
Issue #15:
-URL for Ole P.'s Excel web site
-URL for Aaron Blood's Excel web site
Page 1 of 4 pages
[Next page]
[Next page]
Excel Expert Newsletter Archives
Here you'll find the archives of David Hager's Excel Expert's E-Letter, produced in 1999-2001. This information is old and unorganized, but it's here because it still contains lots of useful information. The newsletters contains quite a few links. Needless to say, most are no longer valid.
It's interesting to note that some of the key problems back then are still key problems today.