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
**********************************
Issue No. 14 (November 1, 1999)
**********************************
COMMENTS
Welcome to the 14th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE is a semi-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
and 16th 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 WEB SITES
See:
http://www.appspro.com
for a group of great free Excel utilities that have finally found a home.
**********************************
POWER FUNCTION TECHNIQUE
by Stephen Bullen and David Hager
These functions are modifications of an user-defined function made by
Stephen Bullen and published in the Feb'99 issue of PC World magazine.
All of these functions are primarily designed to be used as a condition
for conditional formatting, as they are meant to be used with a single
cell range. When used with multi-cell ranges, these functions will return
True if the range argument intersects the filter range. Determining if
the range argument is a subset of the filter range would require the
comparison of the intersection of the range argument and the filter range
to see if it was equal to the range argument.
Function InFilterList(Rng As Range) As Boolean
On Error GoTo TheEnd
InFilterList = False
If Not Intersect(Rng, Rng.Parent.AutoFilter.Range) _
Is Nothing Then
InFilterList = True
End If
Exit Function
TheEnd:
End Function
The InFilterList function returns True if the range in question is
located in a filter range. This is the range where the Data, AutoFilter
has been applied but no criteria has been chosen. The act of adding
or removing the autofilter does not cause a recalculation of this
function when it is used in a conditional formatting formula. Thus,
a recalculation on the worksheet is needed for the conditional format
to be applied.
Function InFilteredList(Rng As Range) As Boolean
On Error GoTo TheEnd
InFilteredList = False
With Rng.Parent.AutoFilter
If Not Intersect(Rng, .Range) Is Nothing Then
For n = 1 To .Range.Columns.Count
If .Filters(n).On Then
InFilteredList = True
Exit For
End If
Next
End If
End With
Exit Function
TheEnd:
End Function
The InFilteredList function returns True if the range in question is
located in a filtered range. Since the application of the filter is
recognized by Excel as a change requiring a recalculation, this function
will afford dynamic formatting changes to cells when used in conjunction
with conditional formatting.
Function InFilteredField(Rng As Range) As Boolean
On Error GoTo TheEnd
InFilteredField = False
With Rng.Parent.AutoFilter
If Not Intersect(Rng, .Range) Is Nothing Then
If .Filters(Rng.Column - .Range.Column + 1).On Then
InFilteredField = True
End If
End If
End With
Exit Function
TheEnd:
End Function
The InFilteredField function returns True if the range in question is
located in a column to which a filter has been applied. If the entire
filter range has been conditionally formatted, all of the columns that
have a set criteria will display the desired formatting.
**********************************
VBA CODE EXAMPLES
by Stephen Bullen
This procedure delinks all of the charts in a workbook.
Sub RemoveChartLinks()
Dim oSht As Worksheet, oCht As ChartObject, oSeries As Series
'From all embedded charts
For Each oSht In ActiveWorkbook.Worksheets
For Each oCht In oSht.ChartObjects
For Each oSeries In oCht.Chart.SeriesCollection
With oSeries
.Name = .Name
.Values = .Values
.XValues = .XValues
End With
Next
Next
Next
'From all chart sheets
For Each oCht In ActiveWorkbook.Charts
For Each oSeries In oCht.SeriesCollection
With oSeries
.Name = .Name
.Values = .Values
.XValues = .XValues
End With
Next
Next
End Sub
by Jim Rech
This procedure opens an application through the use of the Shell function
and it allows for the lag time involved with the opening process.
Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Sub Test()
Dim StartTime As Double
StartTime = Now
ShellAndWait "calc.exe", 1
MsgBox "Gone " & Format(Now - StartTime, "s") & " seconds"
End Sub
'Window States (Per Help for Shell function):
' 1, 5, 9 Normal with focus.
' 2 Minimized with focus.
' 3 Maximized with focus.
' 4, 8 Normal without focus.
' 6, 7 Minimized without focus.
Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
by Jim Rech
This procedure removes all code and related structures from a workbook.
''Needs a reference to the VB Extensibility library set
'Removes from active workbook all:
''Regular modules
''Class modules
''Userforms
''Code in sheet and workbook modules
''Non built-in references
''Excel 4 macro sheets
''Dialog sheets
Sub RemoveAllCode()
'XL2K:
'Dim VBComp As VBComponent, AllComp As VBComponents, ThisProj As
VBProject
'XL97 & XL2K:
Dim VBComp As Object, AllComp As Object, ThisProj As Object
Dim ThisRef As Reference, WS As Worksheet, DLG As DialogSheet
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Set ThisProj = ActiveWorkbook.VBProject
Set AllComp = ThisProj.VBComponents
For Each VBComp In AllComp
With VBComp
Select Case .Type
Case vbext_ct_StdModule, vbext_ct_ClassModule, _
vbext_ct_MSForm
AllComp.Remove VBComp
Case vbext_ct_Document
.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
End Select
End With
Next
For Each ThisRef In ThisProj.References
If Not ThisRef.BuiltIn Then ThisProj.References.Remove ThisRef
Next
End If
Application.DisplayAlerts = False
For Each WS In Excel4MacroSheets
WS.Delete
Next
For Each DLG In DialogSheets
DLG.Delete
Next
End Sub
**********************************
POWER PROGRAMMING TECHNIQUES
by David Hager
Data normalization is a task that is commonly applied in a variety
of data workups. When normalized, the sum of the data equals some
value that is set by an arbitrary or real constraint. In Excel, the
normalization process is accomplished with a column (or row) of
formulas appropriate to the task. The following technique provides
a way to convert data to a normalized form without the use of
formulas.
Sub NormalizeRangeValues(Optional nRange As String, _
Optional nValue As Double = 1)
If nRange = "" Then
nRange = Selection.Address
End If
nSum = Application.WorksheetFunction.Sum(Range(nRange))
If nSum = 0 Then Exit Sub
For Each nCell In Range(nRange)
With nCell
If .Value <> "" Then
.Value = (nValue / nSum) * .Value
End If
End With
Next
End Sub
Sub NormalizeTableValues(tRange As String, _
Optional nVal As Double = 1, Optional CoR As Boolean = True)
Dim n As Integer
If CoR Then
CoR_Count = Range(tRange).Columns.Count
Else
CoR_Count = Range(tRange).Rows.Count
End If
For n = 1 To CoR_Count
NormalizeRangeValues RangeSection(tRange, n, CoR), nVal
Next
End Sub
Function RangeSection(tRange As String, _
posNum As Integer, Optional ByCol As Boolean = True) As String
Dim cOffset As Integer
Dim rOffset As Integer
Dim cSize As Integer
Dim rSize As Integer
cOffset = 0
rOffset = 0
cSize = 1
rSize = 1
Set mRange = Range(tRange)
If ByCol Then
cOffset = posNum - 1
rSize = mRange.Rows.Count
Else
rOffset = posNum - 1
cSize = mRange.Columns.Count
End If
Set sRange = mRange.Offset(rOffset, cOffset).Resize(rSize, cSize)
RangeSection = sRange.Address
End Function
Apart from its use with the normalization technique, the RangeSection
function can be useful for returning the address of a row or column within
a specified range. The function is constructed to return a string, but it
can just as easily be made to return a Range object.
Sub RunNormalizeTable()
Application.EnableEvents = False
NormalizeTableValues Selection.Address, 2.5, False
Application.EnableEvents = False
End Sub
The procedure shown above will normalize the data in all of the rows in
a selected data table to a value of 2.5.
When writing a procedure that incorporates a general utility macro,
it is a good idea to disable/enable events in that procedure if it
triggers an event that is not inherent to the function of that utility.
In the case of using the NormalizeRangeValues function, the cell values
are changed, so that will start any application, workbook or worksheet
level change event for each cell changed. If those event procedures
contain code, that code will run with each change, which may not be
the desired outcome.
by David Hager
The following event procedures work together to place the contents of a cell
into a cell comment when another entry is made. For example, if a cell
contains a value of 13, and 23 is entered in the cell, the cell comment will
contain the statement:
"Previous entry was 13"
Public acVal
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error Resume Next
Target.AddComment
Target.Comment.Text "Previous entry was " & acVal
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If ActiveCell.Address <> Target.Address Then Exit Sub
If Target.Value = "" Then
acVal = ""
Else
acVal = Target.Value
End If
End Sub
The cell value is stored in a public variable when a cell is selected. Then,
when a new value is added, the Worksheet_Change event procedure adds a cell
comment (the error generated if the cell already has a comment is stepped
over) and then uses the stored variable as part of the text string for the
comment. This technique could be easily modified to add all of the changes
made to a cell over time to the comment.
**********************************
Issue No.14 OF EEE (PUBLISHED 01Nov1999)
Next issue scheduled for 16Nov1999.
BY David Hager
dchager@compuserve.com
**********************************
Issue No. 13 (October 15, 1999)
Excel Magic Consolidator(MagicCons.xls)
by David Hager
Copyright @1999 All Rights Reserved
Feel free to use this technique in your Excel projects, as long as you
include a statement as to the original source.
There are no examples of the formulas referred to in this text in the
working xl file, but you should be able to construct your own, based
on the following information.
1) Basic Instructions
a) What does it do?
It allows the user to write formulas on the consolidation worksheet (called
"Summary" by default) that act on the same cell from every worksheet in the
workbook. The results of the formulas change dynamically as sheets are
added/deleted from the workbook. Also, the summary sheet can be located at
any position within the workbook. There is no VBA or xlm macro code used
in this solution. All of the work is done by defined name formulas.
b) Writing the formulas
As an example, if you type the formula =SUM(cCell) in cell B4 on the Summary
worksheet, that formula will return the sum of cell B4 for every worksheet
in the workbook, since cCell as used in cell B4 returns the array of entries
for those worksheets. Information about using arrays that return entries
from cells offset from the cells they are used in can be found in 2a.
c) Changing the consolidation sheet name
To change the consolidation sheet name, go to Insert, Name, Define in the
menu. The named formula called TheSummarySheetName is defined as ="Summary".
This means that the worksheet named "Summary" is the only sheet in the
workbook that can be used with the consolidation formulas. If, for example,
you want change the name to "ConsSheet", then you need to define
TheSummarySheetName as ="ConsSheet". Of course, you must have a worksheet
by that name as well.
d) Exporting to an existing workbook
To export this functionality to another workbook, you need to use the Move
or Copy menu item from the popup menu that is available when you right-click
a worksheet tab. In this case, right-click the Summary tab (or whatever
name you may have changed it to). Then, select the desired workbook and
sheet location from the dialog box and the checkbox named "Create a copy"
and press Enter. All of the defined name formulas will copy over to the
new workbook (and of course it is not necessary for your workbook to be
named MagicCons.xls). Note that a new workbook must first be saved for this
technique to work.
2) How does it work?
a) Understanding the formulas
All of the formulas used to create the consolidation are defined name
formulas. You can view them by selecting Insert, Name, Define from the
menu. Do not change these formulas unless you understand how they work.
There are 4 constants defined for use in the z-relative formulas. By default,
the defined name formulas down, left, right and up have been assigned a
value of 1.
TheSummarySheetName is defined as:
="Summary"
This is a defined name formula that sets the name of the worksheet to be
used as the consolidation worksheet.
ThisSheet is defined as:
=LEFT(GET.DOCUMENT(1),FIND("]",GET.DOCUMENT(1)))&TheSummarySheetName
This formula returns the sheet name of the consolidation worksheet in the
form "[MagicCons.xls]Summary". This string will be different if used in
another workbook and/or with a different consolidation worksheet. This
string will be used to match the same string in the TheSheets formula.
TheSheets is defined as:
=IF(GET.WORKBOOK(1)=ThisSheet,"",GET.WORKBOOK(1))
The GET.WORKBOOK(1) xlm macro function returns an array of names for the
worksheets in the workbook. This formula modifies that array to return an
array with an empty string for the array item corresponding to the
consolidation worksheet. NOTE: You can modify this formula to exclude
worksheets other than the "Summary" sheet (if you know how ).
cCell is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN())))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN()))))
The concatenated string in the formula INDIRECT(TheSheets&"!"&ADDRESS(ROW()
,COLUMN())) creates an array of cell addresses for the cell in which the
formula resides all of the worksheets in the workbook. The worksheet cell
address for the position on the consolidation worksheet is constructed
incorrectly by design so that a circular reference to that cell will not
be created. When that string is acted on by the INDIRECT function, a 3-D or
z-range is created. Due to a glitch in how Excel returns this array, it
must be acted on by the N function to produce a true array.
cCellDown is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()+down,COLUMN())))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()+down,COLUMN()))))
cCellLeft is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN()-left)))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN()-left))))
cCellRight is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN()+right)))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN()+right))))
cCellUp is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()-up,COLUMN())))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()-up,COLUMN()))))
Realize that in order to use offset arrays of differing dimensions, you will
have to define you own hard-coded formulas, such as:
cCellUp4 is defined as:
=IF(ISERROR(N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()-4,COLUMN())))),"",
N(INDIRECT(TheSheets&"!"&ADDRESS(ROW()-4,COLUMN()))))
b) Using arrays with "non-3D enabled" Excel functions
There are quite a few Excel functions that do not work with the 3D ranges
that are inherent to Excel. For example, the MATCH function cannot be as
shown in the following formula.
=MATCH(2, Sheet1:Sheet7!C1, 0)
However, this formula does work as expected.
=MATCH(2, cCell, 0)
In the former case, the 3D range reference Sheet1:Sheet7!C1 does not give
an array that the MATCH function can operate on. The latter case contains
the readable array cCell (which can be viewed by evaluating that portion
of the formula in the formula bar) that MATCH does work with.
c) Z-relative array formulas
Since real arrays are returned by cCell and its cousins, they can be used
just like any normal range is used in an array formula.
3) Problems
a) Circular references
If you try to use the consolidation formulas on any other worksheet than
the designated consolidation sheet, a circular reference will be created.
Do not use these formulas on other worksheets!
b) Sheets other than worksheets
The presence of charts and Excel5 dialog sheets do not interfere with the
workings of the consolidation formulas. However, an Excel4 macro sheet
will behave as if was a regular worksheet. This should not cause a problem
in most cases, but if you have entries in cells that correspond to the
cell ranges you have chosen for consolidation, they will be used in the
formulas.
c) "Incorrect" result from formulas
The z-relative arrays contain the same number of items as the number of
worksheets in your workbook, and that includes the consolidation worksheet.
As such, the COUNTA function will always return that number when used with
the cCell (and similar) arrays. The value zero is returned from empty cells
and so the COUNT function will count those cells. For the same reason, the
SMALL, AVERAGE AND MIN functions may not return the expected answer. Thus,
it is recommended that these functions not be used in the consolidation
formulas, unless you are sure that each worksheet for a specified cell
contains an entry.
d) Only returns values
These formulas have been constructed to return only arrays of values. This
was done by design, since consolidation is performed on numbers. All text
entries are converted to zero. However, if you would prefer a solution
that does include text entries in the arrays, follow these steps:
Define nCell as =N(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN())))
Define tCell as =T(INDIRECT(TheSheets&"!"&ADDRESS(ROW(),COLUMN())))
Define cCell as =IF(ISERROR(nCell),"",IF(tCell<>"",tCell,nCell))
Of course you would need to do this for the offset arrays as well. I leave
that as an exercise to the reader.
**********************************
Issue No.13 OF EEE (PUBLISHED 15Oct1999)
Next issue scheduled for 1Nov1999.
BY David Hager
dchager@compuserve.com
**********************************
Issue No. 12 (October 1, 1999)
**********************************
COMMENTS
Welcome to the 12th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE is a semi-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 and
16th of each month. See:
http://www.j-walk.com/ss/excel/eee/index.htm
**********************************
TOP EXCEL WEB SITES
Lots of useful information at David McRitchie's web site.
http://members.aol.com/dmcritchie/excel/excel.htm
**********************************
POWER FORMULA TECHNIQUE
by David Hager
Give a range of values (in this case B1:D3), find the maximum value and
return the corresponding character in the adjacent column (in this case
A1:A3). For the example shown below the answer is "z".
x 1 4 7
y 2 5 8
z 3 6 9
The following array formula will return the desired result.
=INDEX(A1:A3,MAX((B1:D3=MAX(B1:D3))*ROW(A1:A3)))
**********************************
VBA CODE EXAMPLES
by David Hager
This procedure works in a similar manner to the Edit Fill Across Worksheets
command in that it operates on a selection and the selected sheets, but
formulas in the selection containing relative references are filled in a
sheet-relative manner.
Sub FillSpecial()
Msg = "Do you want to add the sheet name to all references in your selection ?"
Style = vbYesNo + vbDefaultButton2
Title = "Add Sheet Name?"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
Application.StatusBar = "Converting references..."
Add_Sheet_Name_to_Formulas
End If
On Error GoTo EOP
Application.StatusBar = "Starting fill special..."
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim SheetPosNum As Integer
Dim SSPNum As Integer
Dim wbrray()
Dim ssrray()
Dim m As Integer
Dim n As Integer
Dim y As Integer
Dim z As Integer
Dim sscount As Integer
Dim CurSheet As String
Dim ASName As String
Dim RSName As String
Dim errval As Variant
ReDim wbrray(1 To ActiveWorkbook.Sheets.Count)
ReDim ssrray(1 To Windows(1).SelectedSheets.Count)
If Windows(1).SelectedSheets.Count = 1 Then
Application.StatusBar = False
Exit Sub
End If
n = 1
For Each s In ActiveWorkbook.Sheets
RSName = Application.Substitute(s.Name, " ", "")
RTName = Application.Substitute(RSName, "(", "")
RUName = Application.Substitute(RTName, ")", "")
If s.Name <> RUName Then
Msga = "The sheetname [" & s.Name & "] needs to be " & _
"modified to workwith formulas. Is it OK?"
Stylea = vbYesNo + vbDefaultButton1
Titlea = "Change Sheet Name?"
Responsea = MsgBox(Msga, Stylea, Titlea)
If Responsea = vbYes Then
Sheets(s.Name).Name = RUName
wbrray(n) = RUName
End If
Else
wbrray(n) = s.Name
End If
n = n + 1
Next
sscount = Windows(1).SelectedSheets.Count
Application.StatusBar = "0 of " & sscount & " worksheets finished."
ASName = ActiveSheet.Name
SheetPosNum = Application.Match(ASName, wbrray, 0)
ActiveWindow.SelectedSheets.FillAcrossSheets Range:=Selection, Type _
:=xlContents
m = 1
For Each s In Windows(1).SelectedSheets
ssrray(m) = s.Name
m = m + 1
Next
ActiveSheet.Select
For t = 1 To sscount
Application.StatusBar = t & " of " & sscount & " worksheets finished."
CurSheet = Application.Index(ssrray, t)
Worksheets(CurSheet).Activate
SSPNum = Application.Match(ssrray(t), wbrray, 0)
y = ActiveWorkbook.Sheets.Count
Selection.Replace What:="=", Replacement:="(/)", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False
For Each r In wbrray
Selection.Replace What:=wbrray(y), Replacement:="ZZZ00" & y, LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False
y = y - 1
Next
z = ActiveWorkbook.Sheets.Count
For Each q In wbrray
Selection.Replace What:="ZZZ00" & z + SheetPosNum - SSPNum, _
Replacement:=wbrray(z), LookAt:=
xlPart, SearchOrder:=xlByRows, MatchCase:=False
z = z - 1
Next
Selection.Replace What:="(/)", Replacement:="=", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False
For Each CurCell In Selection
If IsError(CurCell) Then
errval = CurCell.Value
Select Case errval
Case CVErr(xlErrName)
CurCell.Formula = ""
Case CVErr(xlErrRef)
CurCell.Formula = ""
End Select
End If
Next
Next
Worksheets(SheetPosNum).Activate
Application.StatusBar = False
Exit Sub
EOP:
MsgBox "Illegal formula reference attempted. Examine all " & _
"filled formulas and try again."
Worksheets(SheetPosNum).Activate
Application.StatusBar = False
End Sub
Sub Add_Sheet_Name_to_Formulas()
Dim CurrentSheet As String
On Error GoTo EOSH
CurrentSheet = ActiveSheet.Name
Application.ReferenceStyle = xlR1C1
Application.ScreenUpdating = False
With Selection
.Replace What:="RA", Replacement:="ARZZ"
.Replace What:="RE", Replacement:="ERZZ"
.Replace What:="RI", Replacement:="IRZZ"
.Replace What:="RO", Replacement:="ORZZ"
.Replace What:="+R", Replacement:="+" & CurrentSheet & "!R"
.Replace What:="-R", Replacement:="-" & CurrentSheet & "!R"
.Replace What:="(R", Replacement:="(" & CurrentSheet & "!R"
.Replace What:=",R", Replacement:="," & CurrentSheet & "!R"
.Replace What:="/R", Replacement:="/" & CurrentSheet & "!R"
.Replace What:="~*R", Replacement:="*" & CurrentSheet & "!R"
.Replace What:="=R", Replacement:="=" & CurrentSheet & "!R"
.Replace What:=" R", Replacement:=" " & CurrentSheet & "!R"
.Replace What:="^R", Replacement:="^" & CurrentSheet & "!R"
.Replace What:="&R", Replacement:="&" & CurrentSheet & "!R"
.Replace What:="(C[", Replacement:="(" & CurrentSheet & "!C["
.Replace What:=" C[", Replacement:=" " & CurrentSheet & "!C["
.Replace What:="=C[", Replacement:="=" & CurrentSheet & "!C["
.Replace What:="~*C[", Replacement:="*" & CurrentSheet & "!C["
.Replace What:="/C[", Replacement:="/" & CurrentSheet & "!C["
.Replace What:="ORZZ", Replacement:="RO"
.Replace What:="IRZZ", Replacement:="RI"
.Replace What:="ERZZ", Replacement:="RE"
.Replace What:="ARZZ", Replacement:="RA"
End With
Application.ReferenceStyle = xlA1
Exit Sub
EOSH:
MsgBox "Not all references may have converted correctly."
Application.ReferenceStyle = xlA1
End Sub
by Dana DeLouis
This procedure converts normal formulas to those that show an empty cell
if an error condition exists in the original formula.
Sub ErrorTrapAddDDL()
' Adds =If(IsError() around formulas
Dim cel As Range
Dim rng As Range
Dim Check As String
Const Equ As String = "=IF(ISERROR(_x) ,"""", _x)"
Check = Left$(Equ, 12) & "*" ' Check for =IF(ISERROR(
On Error Resume Next
Set rng = Selection.SpecialCells(xlFormulas, 23)
If rng Is Nothing Then Exit Sub
With WorksheetFunction
For Each cel In rng
If Not cel.Formula Like Check Then
cel.Formula = .Substitute(Equ, "_x", Mid$(cel.Formula, 2))
End If
Next
End With
End Sub
**********************************
DO YOU KNOW?...
that you can use defined names in a workbook that are defined in another
workbook. For example, if TheValue is defined as 4 in BookB.xls, typing
=BookB.xls!TheValue in a cell in another workbook will return the value 4.
However, the workbook containing the defined name formua must be open for
this to work. This is NOT true for defined name ranges. These can be used
to communicate with CLOSED workbooks! So, for example, if TheRange is defined
as Sheet1!A1:A3 in BookB.xls, typing =SUM(BookB.xls!TheRange) in a cell in
another workbook will return the value 17 (if that range contains the values
1,2 and 14). When the workbook containing the defined name range is closed,
the full path of BookB.xls will be shown in the formula. Recalculation of
that formula continues to return the value 17. Unfortunately, the range
cannot be defined with the OFFSET function as an expanding range, such as:
=OFFSET(Sheet1!$A$1,,,COUNTA(Sheet1!$A:$A),)
since this fits into the category of defined name formulas described earlier
which do not work with closed workbooks. However, it works fine when the
workbook is open.
An important sidenote to the use of defined names is the transport of defined
names to another workbook. If you type =MyIncrediblyComplexDFFormula in a
cell in the same workbook it is defined in, then copy/paste that cell to
another workbook, the defined name formula associated with that formula
(along with any dependent defined name formulas) will be copied to that
workbook as well. This is true even if the workbook and worksheet is
completely protected. A method of preventing this from occurring is the
attachment of an xlm function of your choosing to the formula (perhaps one
that always returns 0). Since xlm functions cannot be used directly on a
worksheet, the destination workbook will not accept the paste operation.
**********************************
Issue No.12 OF EEE (PUBLISHED 01Oct1999)
Next issue scheduled for 16Oct1999.
BY David Hager
dchager@compuserve.com
**********************************
Issue No. 11 (September 15, 1999)
**********************************
COMMENTS
Welcome to the 11th issue of the Excel Experts E-letter (or EEE), by
David Hager. EEE is a semi-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 and
16th of each month.
http://www.j-walk.com/ss/excel/eee/index.htm
This publication resumes its normal schedule after 6 weeks of inactivity.
I appreciate all of the positive comments I received during this time off.
**********************************
TOP EXCEL WEB SITES
Here is a list of web sites for products that will find/remove passwords
from Excel workbooks/projects/worksheets. This list was compiled by Tom
Ogilvy.
http://www.accessdata.com
http://www.crak.com
http://www.lostpassword.com
http://www.elkraft.unit.no/~huse/xlpassword.htm
http://www.elkraft.ntnu.no/~huse/xlpassword.htm
http://www.elcomsoft.com/ae97pr.html
http://home.telia.no/exceltips/
http://www.zuarin.de/sec_eng.htm
http://webdon.com/mso/
services:
http://www.pwcrack.com/
http://www.passwordservice.com/crack.html
**********************************
WORKSHEET FORMULA TIP
by Bob Umlas
This array formula is an example of a case-sensitive MATCH function.
=MATCH(TRUE,EXACT("A",MyRange),0)
by George Simms
This array formula will extract the phone number as text in the form of
123-45678 from examples as shown below.
234-5678PG
Result 234-5678
Array enter the formula and copy it down as far as needed for entries
in column A.
=MID(A1,MATCH(FALSE,ISERROR(1*MID(A1,ROW(INDIRECT("1:20")),1)),0),21-
SUM(1*ISERROR(1*MID(A1,ROW(INDIRECT("1:20")),1))))
**********************************
POWER FORMULA TECHNIQUE
by Stephen Bullen
This formula perform 'bankers rounding' for a number (Num) to a given number
(Plc) of significant digits.
=MROUND(Num,IF(VALUE(RIGHT(Num/10^(INT(LOG(ABS(Num)))-Plc+1),2))=0.5,2,1)*
SIGN(Num)*10^(INT(LOG(ABS(Num)))-Plc+1))
If you define 'Fact' as =10^(INT(LOG(ABS(Num)))-Plc+1), this reduces to:
=MROUND(Num,IF(VALUE(RIGHT(Num/Fact,2))=0.5,2,1)*SIGN(Num)*Fact)
**********************************
VBA CODE EXAMPLES
by Jim Rech (and others)
This procedure selects the last used cell in a worksheet.
Sub GotoLast()
On Error Resume Next
Application.ScreenUpdating = False
Cells(Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row, _
Cells.Find("*", Range("A1"), , , xlByColumns, xlPrevious).Column).Select
If Err.Number <> 0 Then MsgBox "No data in sheet"
Application.ScreenUpdating = True
End Sub
by Stephen Bullen
This function returns the dimension order of an array (up to 4D).
Public Function fnGetDimension(vaArray)
Dim i As Integer, l As Long
On Error Resume Next
Err.Clear
For i = 1 To 4
l = UBound(vaArray, i)
If Err.Number <> 0 Then Exit For
fnGetDimension = i
Next
Err.Clear
End Function
by John Green
This procedure brings data into a worksheet from an external source
using ADO. Note that use of the Transpose function will introduce
array size limitations in versions of Excel previous to Excel 2000.
Sub GetDataWithADOIn97()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ws As Worksheet
Dim recArray As Variant
Dim fldCount As Integer
Dim iCols As Integer
Dim recCount As Long
Set ws = ActiveSheet
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\My Documents\SalesDb.mdb;"
rst.Open "Select * From SalesData", cnt
fldCount = rst.Fields.Count
For iCols = 0 To fldCount - 1
ws.Cells(1, iCols + 1).Value = rst.Fields(iCols).Name
Next
'Copy records to array
recArray = rst.GetRows
recCount = UBound(recArray, 2)
'Transpose array into worksheet
ws.Range(ws.Cells(2, 1), ws.Cells(recCount + 1, fldCount)).Value _
= Application.Transpose(recArray)
End Sub
by John Walkenbach
This sub prints (in the Immediate window) the same list of files displayed
by the Edit-Links menu command.
Sub ShowLinks()
On Error Resume Next
For Each Lnk In ActiveWorkbook.LinkSources(xlExcelLinks)
Debug.Print Lnk
Next Lnk
For Each Lnk In ActiveWorkbook.LinkSources(xlOLELinks)
Debug.Print Lnk
Next Lnk
End Sub
by Rob Bovey
This simple procedure displays the chart wizard dialog box.
Sub ShowChartWizard()
CommandBars("Standard").FindControl(,436).Execute
End Sub
by Jim Rech
Excel does not support automatically adjusting the row height of a merged
cell with wrap text set. This procedure serves as a workaround.
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
by Bernie Deitrick
This procedure returns the named ranges that include the active cell.
Sub DetermineRangeInclusion()
Dim myName As Name
Dim myAddress, myMessage As String
Dim InRange As Integer
myMessage = "Cell " & ActiveCell.Address & " is not in a Range"
InRange = 0
For Each myName In Application.Names
myAddress = myName.RefersTo
Set b = Intersect(ActiveCell, Range(myAddress))
If Not (b Is Nothing) Then
If InRange = 0 Then
InRange = 1
myMessage = "Cell " & b.Address & Chr(10) & Chr(13) & " is in " & myName.Name
Else: myMessage = myMessage & Chr(10) & Chr(13) _
& " and in " & myName.Name
End If
End If
Next myName
MsgBox myMessage
End Sub
by Jan Karel Pieterse
This procedure searches through all worksheets in a workbook.
Sub FindItAll()
Dim oSheet As Object
Dim Firstcell As Range
Dim NextCell As Range
Dim WhatToFind As Variant
WhatToFind = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)
If WhatToFind <> "" And Not WhatToFind = False Then
For Each oSheet In ActiveWorkbook.Worksheets
oSheet.Activate
oSheet.[a1].Activate
Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Firstcell Is Nothing Then
Firstcell.Activate
MsgBox ("Found " & Chr(34) & WhatToFind & Chr(34) & " in " & oSheet.Name & "!" & Firstcell.Address)
On Error Resume Next
While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address)
Set NextCell = Cells.FindNext(After:=ActiveCell)
If Not NextCell.Address = Firstcell.Address Then
NextCell.Activate
MsgBox ("Found " & Chr(34) & WhatToFind & Chr(34) & " in " & oSheet.Name & "!" & NextCell.Address)
End If
Wend
End If
Set NextCell = Nothing
Set Firstcell = Nothing
Next oSheet
End If
End Sub
**********************************
EXCEL PRODUCTIVITY TIPS
by Rob Bovey
When the merge cells feature is used on a worksheet, it is difficult to
make additional formatting changes to columns/rows that contain the merged
cell(s).
The best workaround in this case is just not to use the merge cells feature.
The old center across selection, which does the same thing for most purposes
and causes no problems, is still available. It's just hidden under the
Format/Cells/Alignment menu at the bottom of the Horizontal dropdown.
by David Hager
There is a quicker way to freeze formulas to values on a worksheet than
using Edit Copy, then Edit Paste Special and choosing the Values option.
After making a selection, right-click its edge and drag it away slightly.
Then, place it back in its original position. When you do that, a popup
menu appears. Select the Copy Here as Values option and you are finished.
**********************************
DO YOU KNOW?...
that if you apply the Protect method with the UserInterfaceOnly argument
set to True to a worksheet and then save the workbook, the entire worksheet
(not just the interface) will be fully protected when you reopen the workbook.
To unprotect the worksheet but re-enable user interface protection after
the workbook is opened, you must again apply the Protect method with
UserInterfaceOnly set to True.
discoverd by Vasant Nanavati in online help
**********************************
Issue No.11 OF EEE (PUBLISHED 15Sep1999)
Next issue scheduled for 01Oct1999.
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.