********************************** 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 **********************************