Issue No. 15 (December 22, 1999)
**********************************
COMMENTS
Y2K is nearly here!
Welcome to the 15th 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 will appear in EEE #16 (Feb2000).
**********************************
TOP EXCEL WEB SITES
See Ole P.'s web site for lots of great Excel stuff.
http://w1.2735.telia.com/~u273500023/english/index.htm
Go to Aaron Blood's growing Excel site at:
http://geocities.com/aaronblood
**********************************
WORKSHEET FORMULA TIP
by Harlan Grove
??? formula to reverse the sequence of elements in a range ???
This method makes use of matrix multiplication. The idea is pre or
post multiply by a square matrix (N by N)of ones in the elements where
the sum of the row and column indices equal N+1 and zeros elsewhere,
eg, for 3 by 3
0 0 1
0 1 0
1 0 0
Call these matrices R(N), where N is the dimension (N by N), then for A a
matrix with 4 rows and 3 columns, the matrix product R(4) * A reverses the
row order of A while A * R(3) reverses the column order of A.
So if A is
11 12 13
21 22 23
31 32 33
41 42 43
then the array formulas
=MMULT(N(ROW(INDIRECT("1:"&ROWS(A)))=TRANSPOSE(
ROWS(A)+1-ROW(INDIRECT("1:"&ROWS(A))))),A)
and
=MMULT(A,N(ROW(INDIRECT("1:"&COLUMNS(A)))=TRANSPOSE
(COLUMNS(A)+1-ROW(INDIRECT("1:"&COLUMNS(A))))))
give
41 42 43
31 32 33
21 22 23
11 12 13
and
13 12 11
23 22 21
33 32 31
43 42 41
respectively.
**********************************
POWER FORMULA TECHNIQUE
by Bob Umlas
This array formula returns TRUE if the number in cell A1 is a prime number.
=OR(A1=2,A1=3,ISNA(MATCH(TRUE,A1/ROW(INDIRECT("2:"&INT(SQRT(A1))))=
INT(A1/ROW(INDIRECT("2:"&INT(SQRT(A1))))),0)))
Use it as a conditional formatting formula, with A1 as the active cell
in the selection to be formatted.
Here's how Bob's amazing formula works. In a nutshell, the number is
divided by all potential prime factors, and the resulting array is tested
to see whether it contains a whole number. If is does, you have a prime
number. A limitation of this formula is that it cannot test numbers that
are greater than 65535^2. This is due to the array size constraint in
Excel 97/2000.
**********************************
VBA CODE EXAMPLES
by Jake Marx
??? read the names of all Sheets in a closed workbook ???
Here's a way to do it through ADO (ActiveX Data Objects) in Excel
2000. To use this code, you must first set a reference to "Microsoft
ActiveX Data Objects 2.1 Library" and "Microsoft ADO Ext. 2.1 for DDL and
Security".
Sub ReadSheetNames(TheCompleteFilePath As String)
Dim cnn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim tbl As ADOX.Table
cnn.Open "Provider=MSDASQL.1;Data Source=" _
& "Excel Files;Initial Catalog=" & TheCompleteFilePath
cat.ActiveConnection = cnn
For Each tbl In cat.Tables
MsgBox Left$(tbl.Name, Len(tbl.Name) - 1)
Next tbl
Set cat = Nothing
cnn.Close
Set cnn = Nothing
End Sub
by Bill Manville
??? synchronise the horizontal scrolling of 2 windows onto the
same worksheet ???
Place this event procedure in the worksheet module.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' synchronise horizontal scrolling of two windows on the same sheet
Dim W As Window
Dim stCap as String
stCap = ActiveWindow.Caption
Application.ScreenUpdating = False
If Right(stCap, 2) = ":1" Then
Set W = Windows(Left(stCap, Len(stCap) - 2) & ":2")
ElseIf Right(stCap, 2) = ":2" Then
Set W = Windows(Left(stCap, Len(stCap) - 2) & ":1")
Else
Exit Sub ' single window.
End If
W.ScrollColumn = ActiveWindow.ScrollColumn
Application.ScreenUpdating = True
End Sub
by Bill Manville
??? group multiple worksheets and print a selection from the selected
sheets all on one page ???
Sub MultiSheetPrint()
' prints the selected area on each of a set of selected worksheets on
' a single sheet
Dim oActive As Object
Dim oSheet As Object
Dim oSheets As Object
Dim wsPrint As Worksheet
Dim oLastPic As Object
Dim iPics As Integer
' remember where we are
Set oSheets = ActiveWindow.SelectedSheets
If oSheets.Count = 1 Then
Selection.PrintOut preview:=True
Exit Sub
End If
Set oActive = ActiveSheet
Application.ScreenUpdating = False
oActive.Select ' otherwise we get lots of new sheets
Set wsPrint = Worksheets.Add
For Each oSheet In oSheets
If TypeName(oSheet) = "Worksheet" Then
iPics = iPics + 1
oSheet.Activate
Selection.CopyPicture
wsPrint.Cells(iPics * 3 - 2, 1).Value = oSheet.Name
wsPrint.Paste wsPrint.Cells(iPics * 3 - 1, 1)
wsPrint.Rows(iPics * 3 - 1).RowHeight = _
wsPrint.Pictures(iPics).Height
End If
Next
wsPrint.PrintOut preview:=True
Application.DisplayAlerts = False
wsPrint.Delete
Application.DisplayAlerts = True
oSheets.Select
oActive.Activate
Application.ScreenUpdating = True
End Sub
**********************************
POWER FUNCTION TECHNIQUES
by Harlan Grove
This function evaluates first argument, v, and return replacement value,
rep, depending on comparison given by cmp. If cmp is blank, replace all
error values in v with rep. Otherwise, use Evaluate() with v and cmp, and
if the result is True, then replace v with rep.
'
Function EvalReplace(v As Variant, _
Optional cmp As String = "", _
Optional rep As Variant = "") As Variant
Dim i As Long, j As Long, ret() As Variant, x As Variant
If TypeOf v Is Range Then v = v.Value
If Not IsArray(v) Then v = Array(v)
On Error Resume Next
j = UBound(v, 2) - LBound(v, 2) + 1
On Error GoTo 0
If j = 0 Then
ReDim ret(1 To 1, 1 To UBound(v, 1) - LBound(v, 1) + 1)
Else
ReDim ret(1 To UBound(v, 1) - LBound(v, 1) + 1, 1 To j)
End If
i = 1
j = 1
For Each x In v
If cmp = "" Then
If IsError(x) Then ret(i, j) = rep
ElseIf Not IsError(x) Then
If Evaluate("=" & x & cmp) Then ret(i, j) = rep
End If
If IsEmpty(ret(i, j)) Then ret(i, j) = x
If i < UBound(ret, 1) Then
i = i + 1
Else
i = 1
j = j + 1
End If
Next
EvalReplace = ret
End Function
This function is more efficient at replacing error values than it is at
comparison replacements. Nevertheless, when the expression v is complex,
this can be preferable to using v twice in IF().
Examples:
=EvalReplace(SQRT(-1)) returns a zero-length string
=EvalReplace(SQRT(-1),,0) returns 0
=EvalReplace({1,2,3,4},"<2",2) returns {2,2,3,4}
**********************************
POWER PROGRAMMING TECHNIQUES
by Stephen Bullen
??? assign a procedure to the Click event of a command button added to
a form at run time ???
[Class CBtnEvents]
Public WithEvents oBtn As MSForms.CommandButton
Private Sub oBtn_Click()
'... Your code
End Sub
[In the Form]
Dim oEvents As New Collection
Private Sub Userform_Initialize()
Dim oBtnEvts As CBtnEvents
Set oBtnEvts = New CBtnEvents
Set oBtnEvts.oBtn =
FrmFieldShow.Controls.Add(bstrprogid:="forms.commandbutton.1", _
Name:="CmdToG", Visible:=True)
With oBtnEvts.oBtn
.Top = 50
.Height = 25
.Width = 100
.Left = (FrmFieldShow.Width / 2 - (100 / 2))
.Caption = "Ok"
end with
oEvents.Add oBtnEvts
End Sub
When you click the button, the routine in the class module will fire.
by Laurent Longre
??? add a Add-In path dynamically while it's loading, so the path can be
adjusted according to the location of other applications ???
Since the calls to the XLA functions create a link to the XLA file in
question, you can test if the path of the add-in is not the same as the
path of the link. You should test this in all the workbooks which are
already open at load-time of the add-in, and in all the workbooks which
will be opened after the add-in is installed.
Dim WithEvents App As Application
Private Sub App_WorkbookOpen(ByVal Wb As Excel.Workbook)
TestLink Wb
End Sub
Private Sub TestLink(Wb As Workbook)
Dim Link, I As Integer
If IsEmpty(Wb.LinkSources(xlExcelLinks)) Then Exit Sub
For Each Link In Wb.LinkSources(xlExcelLinks)
If Link = Me.FullName Then Exit Sub
For I = Len(Link) To 1 Step -1
If Mid$(Link, I, 1) = "\" Then Exit For
Next I
If Mid$(Link, I + 1) = Me.Name Then
Wb.ChangeLink Link, Me.FullName, xlExcelLinks
Exit Sub
End If
Next Link
End Sub
Private Sub Workbook_Open()
Dim Wb As Workbook
For Each Wb In Workbooks
TestLink Wb
Next Wb
Set App = Application
End Sub
**********************************
SPECIAL VBA PROJECT: Custom Number Formats
by Guy Boertje
Finds all of the user-defined custom number formats in a workbook.
Here's how it works.
1) Save a temporary copy of the workbook.
2) Open the raw binary file.
3) Find the bottom of file (BOF) marker in the Workbook globals stream of
the compound OLE2 doc.
4) Find the end of file (EOF) marker in the Workbook globals stream.
5) Scan between the first byte and the EOF mark looking for number format
records.
6) If one is found, extract the number format string and add it to a
collection.
7) Stop when the EOF mark is reached. Close the binary file.
8) Convert the collection of strings to an array of strings.
9) Return the array.
Option Explicit
Const csNNF As String = "not number format"
Sub RetrieveCustomNumbersFormats()
Dim v, i As Integer
v = getCustomNumberFormats(ActiveWorkbook)
For i = 0 To UBound(v)
ActiveSheet.Cells(i + 1, 1) = v(i)
Next
End Sub
Public Function getCustomNumberFormats(wb As Workbook) As Variant
'input - a workbook object
'output - an array of strings
Const BOF_L As Byte = 9, BOF_U As Byte = 8
Const FMT_L As Byte = 30, FMT_U As Byte = 4, U_IDX As Integer = 160
Const EOF_L As Byte = 10, EOF_U As Byte = 0
'change these constants to suit the path to the temp folder on your system
Const drv As String = "C:", stp As String = "TEMP",
fold As String = "WINDOWS"
Dim hFile As Long, lngLen As Long, i As Long, fIs97 As Boolean
Dim NumFormats() As String, s As String, sep As String
Dim sPath As String, c As New Collection, wbA As Workbook
Dim lngBegin As Long, lngEnd As Long
'first we need to create a temporary copy of the file to scan
sep = Application.PathSeparator
'### adjust below to suit location of your temp folder
' sPath = drv & sep & stp & sep & wb.Name
sPath = drv & sep & fold & sep & stp & sep & wb.Name
'###
'set xl97 file format flag
fIs97 = (wb.FileFormat = xlWorkbookNormal Or wb.FileFormat = xlExcel9795)
wb.SaveCopyAs sPath
hFile = FreeFile
Open sPath For Binary Access Read As hFile
lngLen = LOF(hFile) - 1
If lngLen > 0 Then
'find the beginning of the workbook globals stream
lngBegin = FindBofGlobals(hFile, BOF_L, BOF_U, fIs97)
'find the end of the workbook globals stream
lngEnd = FindEofMarker(hFile, EOF_L, EOF_U)
'sometimes there are number format records before the BOF
'so scan from the first byte
If lngBegin > 0 Then lngBegin = 1
'were the workbook globals markers found?
If lngBegin > 0 And lngEnd > 0 Then
'reset the file position
Seek hFile, lngBegin
Do While Seek(hFile) < lngEnd
'scan for a format record
'i will be the ifmt field
s = getFmtRec(hFile, FMT_L, FMT_U, i, fIs97)
'was one found?
If Not s = csNNF Then
'greater than U_IDX is a custom format
'use AddTo because if we find the same number format
'in a different record we don't want to add it twice
'we might do because we are scanning from the
'start of the file not the start of the workbook
'globals stream
If i > U_IDX Then AddTo c, s
End If
Loop
End If
End If
Close hFile
lngLen = c.Count - 1
'transfer the collection of strings to an array of strings
'I think its better to return an array and keep the collection
'object local
If lngLen >= 0 Then
ReDim NumFormats(lngLen)
For i = 0 To lngLen
NumFormats(i) = c(i + 1)
Next
getCustomNumberFormats = NumFormats
End If
Set c = Nothing
'get rid of the temp file
If Len(Dir(sPath)) > 0 Then Kill sPath
End Function
Private Function getFmtRec(h As Long, Lbyte As Byte, Ubyte As Byte, _
i As Long, f97 As Boolean) As String
Dim rec(1) As Byte, l As Long, s As String, o As Long
Dim t As Long, f As Boolean, bytA As Byte, bytB As Byte
Dim j As Long
'structure of a number format BIFF record
'2 bytes marker
'2 bytes size
'2 bytes ifmt
'1 byte length of the format string (can only be 255 characters long)
'n bytes format string (with two zero bytes if xl97 file fmt)
getFmtRec = csNNF
s = vbNullString
'get the first byte
Get h, , rec(0)
'is it the first part of the number formats marker?
If rec(0) = Lbyte Then
'if so then get the next byte
Get h, , rec(1)
'is it the second part of the number formats marker?
If rec(1) = Ubyte Then
o = getTwoBytes(h) 'get the offset - the size of the record
i = getTwoBytes(h) 'get the ifmt field - number format is
'built-in or custom
t = getOneByte(h) 'get the length of the format string
'check that the offset and the length of the format string
'differ by 5 bytes
l = o - 5
If t <> l Then Debug.Print o; l; t 'if this bit executes then
'there are corrupted records
'in the xl97 file format there are two null bytes before
'the format string
If f97 Then t = t + 2
s = getFormatString(h, t, Ubyte, Lbyte)
If f97 Then
'strip the two null bytes away
getFmtRec = Mid$(s, 3)
Else
getFmtRec = s
End If
End If
End If
End Function
Private Function getFormatString(h As Long, l As Long, Ubyt As Byte, _
Lbyt As Byte) As String
Dim j As Long, byt(1) As Byte, s As String
For j = 1 To l
Get h, , byt(0)
'while getting the string, make sure that
'it is not the start of the next format record
If byt(0) = Lbyt Then
Get h, , byt(1)
If byt(1) = Ubyt Then
'if a number format record is found then
'move the file pointer back two bytes and exit
Seek h, Seek(h) - 2
Exit For
Else
'otherwise move the file pointer back one byte
'making sure that no bytes are skipped
Seek h, Seek(h) - 1
End If
End If
s = s & Chr$(byt(0))
Next
getFormatString = s
End Function
Sub AddTo(c As Collection, s As String)
'will get an error if the key has been used before
'this guarantees that each string in the collection is unique
On Error Resume Next
c.Add Item:=s, key:=s
End Sub
Private Function FindBofGlobals(h As Long, Lbyte As Byte, Ubyte As Byte, _
f97 As Boolean) As Long
Dim rec(1) As Byte, recA(5) As Byte, l As Long, s As String
Dim offs(1) As Byte, bifv(1) As Byte
Dim wgbl(1) As Byte, place As Long, f As Boolean
If f97 Then
'in xl97 the BOF record is 16 bytes long
offs(0) = 16: offs(1) = 0
'biff8 is indicated by a 6 in the upper byte
bifv(0) = 0: bifv(1) = 6
Else
'previously it was 8 bytes long
offs(0) = 8: offs(1) = 0
'biff5or7 is indicated by a 5 in the upper byte
bifv(0) = 0: bifv(1) = 5
End If
'the workgroup globals BOF is marked as 5
'there are other BOFs records, marked differently
wgbl(0) = 5: wgbl(1) = 0
FindBofGlobals = -1
Do
'jump in 2 byte steps until the BOF record or the end of file
'is reached
Get h, , rec
If Seek(h) >= LOF(h) - 7 Then Exit Function
f = (rec(0) = Lbyte And rec(1) = Ubyte)
If f Then
'remember point where we have tested for BOF marker
'now we test for the other elements for a valid wb global bof
place = Seek(h)
Get h, , recA
'is the offset the correct size?
'is the biff version correct?
'is it a wb global bof?
f = recA(0) = offs(0) And recA(1) = offs(1) And _
recA(2) = bifv(0) And recA(3) = bifv(1) And _
recA(4) = wgbl(0) And recA(5) = wgbl(1)
If Not f Then Seek h, place 'move the file pointer back
'to the remembered point
End If
Loop Until f
'return the start point of the bof record
FindBofGlobals = place - 2
End Function
Private Function FindEofMarker(h As Long, Lbyte As Byte, Ubyte As Byte) As Long
Dim rec(1) As Byte, f As Boolean, place As Long
FindEofMarker = -1
Do
'jump in two byte steps until the EOF record or the end of file is
'reached
Get h, , rec
If Seek(h) >= LOF(h) - 5 Then Exit Function
'is it an eof record?
f = (rec(0) = Lbyte And rec(1) = Ubyte)
If f Then
'remember last eof tested point
place = Seek(h)
'are the next two bytes both zero?
'they should be for a valid eof
f = (getTwoBytes(h) = 0)
If Not f Then Seek h, place
End If
Loop Until f
'return the start point of the eof record
FindEofMarker = place - 2
End Function
Private Function getTwoBytes(h As Long) As Long
Dim rec(1) As Byte, l As Long
'returns the next two bytes in the file as a Long
Get h, , rec
getTwoBytes = CLng(rec(0)) + CLng(rec(1)) * 256
End Function
Private Function getOneByte(h As Long) As Integer
Dim rec As Byte
'returns the next byte in the file as an Integer
Get h, , rec
getOneByte = rec
End Function
**********************************
Issue No.15 OF EEE (PUBLISHED 22Dec1999)
Next issue scheduled for 01Feb2000.
BY David Hager
dchager@compuserve.com
**********************************
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.