A major secret of successful programmers is to never waste time writing the same code twice. They all have little bits—or even big bits—of code that are used over and over again. Another big secret is to never take eight hours doing something that can be done in ten minutes—which is what this book is about!
This chapter contains programs donated by several Excel power programmers. These are programs they have found useful, and they hope these will help you, too. Not only can they save you time, but they may also teach you new ways of solving common problems.
Different programmers have different programming styles, and we did not rewrite the submissions. As you review the lines of code, you will notice different ways of doing the same task, such as referring to ranges.
The following utilities deal with handling files in folders. Being able to loop through a list of files in a folder is a useful task.
Submitted by Nathan P. Oliver of Minneapolis, Minnesota. Nathan is a financial consultant and application developer.
This program returns the filename, size, and date modified of all files in the selected directory and its subfolders:
Sub ExcelFileSearch()
Dim srchExt As Variant, srchDir As Variant, i As Long, j As Long
Dim strName As String, varArr(1 To 1048576, 1 To 3) As Variant
Dim strFileFullName As String
Dim ws As Worksheet
Dim fso As Object
Let srchExt = Application.InputBox("Please Enter File Extension", "Info Request")
If srchExt = False And Not TypeName(srchExt) = "String" Then
Exit Sub
End If
Let srchDir = BrowseForFolderShell
If srchDir = False And Not TypeName(srchDir) = "String" Then
Exit Sub
End If
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ws.Name = "FileSearch Results"
Let strName = Dir$(srchDir & "*" & srchExt)
Do While strName <> vbNullString
Let i = i + 1
Let strFileFullName = srchDir & strName
Let varArr(i, 1) = strFileFullName
Let varArr(i, 2) = FileLen(strFileFullName) 1024
Let varArr(i, 3) = FileDateTime(strFileFullName)
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(srchDir), varArr(), i, CStr(srchExt))
Set fso = Nothing
ThisWorkbook.Windows(1).DisplayHeadings = False
With ws
If i > 0 Then
.Range("A2").Resize(i, UBound(varArr, 2)).Value = varArr
For j = 1 To i
.Hyperlinks.Add anchor:=.Cells(j + 1, 1), Address:=varArr(j, 1)
Next
End If
.Range(.Cells(1, 4), .Cells(1, .Columns.Count)).EntireColumn.Hidden = True
.Range(.Cells(.Rows.Count, 1).End(xlUp)(2), _
.Cells(.Rows.Count, 1)).EntireRow.Hidden = True
With .Range("A1:C1")
.Value = Array("Full Name", "Kilobytes", "Last Modified")
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef varArr() As Variant, _
ByRef i As Long, _
ByRef srchExt As String)
Dim SubFolder As Object
Dim strName As String, strFileFullName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "*" & srchExt)
Do While strName <> vbNullString
Let i = i + 1
Let strFileFullName = SubFolder.Path & "" & strName
Let varArr(i, 1) = strFileFullName
Let varArr(i, 2) = FileLen(strFileFullName) 1024
Let varArr(i, 3) = FileDateTime(strFileFullName)
Let strName = Dir$()
Loop
If i > 1048576 Then Exit Sub
Call recurseSubFolders(SubFolder, varArr(), i, srchExt)
Next
End Sub
Private Function BrowseForFolderShell() As Variant
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "C:")
If Not objFolder Is Nothing Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then
BrowseForFolderShell = CStr(objFolder)
Else
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
BrowseForFolderShell = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
BrowseForFolderShell = objFolder.Items.Item.Path
End If
End If
Else
BrowseForFolderShell = False
End If
Set objFolder = Nothing: Set objShell = Nothing
End FunctionSubmitted by Masaru Kaji of Kobe-City, Japan. Masaru provides Excel consultation through Colo’s Excel Junk Room (www.puremis.net/excel/).
If you find yourself importing a lot of comma-separated variable (CSV) files and then having to go back and delete them, this program is for you. It quickly opens up a CSV in Excel and permanently deletes the original file:
Option Base 1
Sub OpenLargeCSVFast()
Dim buf(1 To 16384) As Variant
Dim i As Long
'Change the file location and name here
Const strFilePath As String = "C: empTest.CSV"
Dim strRenamedPath As String
strRenamedPath = Split(strFilePath, ".")(0) & "txt"
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Setting an array for FieldInfo to open CSV
For i = 1 To 16384
buf(i) = Array(i, 2)
Next
Name strFilePath As strRenamedPath
Workbooks.OpenText Filename:=strRenamedPath, DataType:=xlDelimited, _
Comma:=True, FieldInfo:=buf
Erase buf
ActiveSheet.UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close False
Kill strRenamedPath
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End SubSubmitted by Suat Mehmet Ozgur of Istanbul, Turkey. Suat develops applications in Excel, Access, and Visual Basic for MrExcel.com and TheOfficeExperts.com.
This sample takes a different approach to reading a text file. Rather than read one record at a time, the macro loads the entire text file into memory in a single string variable. The macro then parses the string into individual records. The advantage of this method is that you access the file on disk only one time. All subsequent processing occurs in memory and is very fast:
Sub ReadTxtLines()
'No need to install Scripting Runtime library since we used late binding
Dim sht As Worksheet
Dim fso As Object
Dim fil As Object
Dim txt As Object
Dim strtxt As String
Dim tmpLoc As Long
'Working on active sheet
Set sht = ActiveSheet
'Clear data in the sheet
sht.UsedRange.ClearContents
'File system object that we need to manage files
Set fso = CreateObject("Scripting.FileSystemObject")
'File that we like to open and read
Set fil = fso.GetFile("c: est.txt")
'Opening file as a TextStream
Set txt = fil.OpenAsTextStream(1)
'Reading file include into a string variable at once
strtxt = txt.ReadAll
'Close textstream and free the file. We don't need it anymore.
txt.Close
'Find the first placement of new line char
tmpLoc = InStr(1, strtxt, vbCrLf)
'Loop until no more new line
Do Until tmpLoc = 0
'Use A column and next empty cell to write the text file line
sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1).Value = _
Left(strtxt, tmpLoc - 1)
'Remove the parsed line from the variable that we stored file include
strtxt = Right(strtxt, Len(strtxt) - tmpLoc - 1)
'Find the next placement of new line char
tmpLoc = InStr(1, strtxt, vbCrLf)
Loop
'Last line that has data but no new line char
sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1).Value = strtxt
'It will be already released by the ending of this procedure but
' as a good habit, set the object as nothing.
Set fso = Nothing
End SubThe next four utilities demonstrate how to combine worksheets into single workbooks or separate a single workbook into individual worksheets or Word documents.
Submitted by Tommy Miles of Houston, Texas.
This sample goes through the active workbook and saves each sheet as its own workbook in the same path as the original workbook. It names the new workbooks based on the sheet name. It will overwrite files without prompting. You’ll also notice that you need to choose whether you save the file as xlsm (macro-enabled) or xlsx (macros will be stripped). I’ve included both lines, xlsm or xlsx, in the following code but commented out the xlsx lines, making them inactive:
Sub SplitWorkbook()
Dim ws As Worksheet
Dim DisplayStatusBar As Boolean
DisplayStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
Dim NewFileName As String
Application.StatusBar = ThisWorkbook.Sheets.Count & " Remaining Sheets"
If ThisWorkbook.Sheets.Count <> 1 Then
NewFileName = ThisWorkbook.Path & "" & ws.Name & ".xlsm" 'Macro-Enabled
' NewFileName = ThisWorkbook.Path & "" & ws.Name & ".xlsx" _
'Not Macro-Enabled
ws.Copy
ActiveWorkbook.Sheets(1).Name = "Sheet1"
ActiveWorkbook.SaveAs Filename:=NewFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
' ActiveWorkbook.SaveAs Filename:=NewFileName, _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
Else
NewFileName = ThisWorkbook.Path & "" & ws.Name & ".xlsm"
' NewFileName = ThisWorkbook.Path & "" & ws.Name & ".xlsx"
ws.Name = "Sheet1"
End If
Next
Application.DisplayAlerts = True
Application.StatusBar = False
Application.DisplayStatusBar = DisplayStatusBar
Application.ScreenUpdating = True
End SubSubmitted by Tommy Miles.
This sample goes through all the Excel files in a specified directory and combines them into a single workbook. It renames the sheets based on the name of the original workbook:
Sub CombineWorkbooks()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object 'allows for different sheet types
DirLoc = ThisWorkbook.Path & " st" 'location of files
CurFile = Dir(DirLoc & "*.xls")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
' Limit to valid sheet names and remove .xls*
CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If
Next
OrigWB.Close SaveChanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End SubSubmitted by Dennis Wallentin of Ostersund, Sweden. Dennis provides Excel tips and tricks at www.xldennis.com.
This sample uses a specified column to filter data and copies the results to new worksheets in the active workbook.
Sub Filter_NewSheet()
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnStart As Range, rnData As Range
Dim i As Long
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
'Make sure that the first row contains headings.
Set rnStart = .Range("A2")
Set rnData = .Range(.Range("A2"), .Cells(.Rows.Count, 3).End(xlUp))
End With
Application.ScreenUpdating = True
For i = 1 To 5
'Here we filter the data with the first criterion.
rnStart.AutoFilter Field:=1, Criteria1:="AA" & i
'Copy the filtered list
rnData.SpecialCells(xlCellTypeVisible).Copy
'Add a new worksheet to the active workbook.
Worksheets.Add Before:=wsSheet
'Name the added new worksheets.
ActiveSheet.Name = "AA" & i
'Paste the filtered list.
Range("A2").PasteSpecial xlPasteValues
Next i
'Reset the list to its original status.
rnStart.AutoFilter Field:=1
With Application
'Reset the clipboard.
.CutCopyMode = False
.ScreenUpdating = False
End With
End SubSubmitted by Dennis Wallentin.
This program transfers data from Excel to the first table found in a Word document. It uses early binding, so a reference must be established in the VB Editor (using Tools, References) to the Microsoft Word Object Library:
Sub Export_Data_Word_Table()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim i As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnData As Range
Dim vaData As Variant
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
Set rnData = .Range("A1:A10")
End With
'Add the values in the range to a one-dimensional variant-array.
vaData = rnData.Value
'Here we instantiate the new object.
Set wdApp = New Word.Application
'Here the target document resides in the same folder as the workbook.
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "Test.docx")
'Import data to the first table and in the first column of a ten-row table.
For Each wdCell In wdDoc.Tables(1).Columns(1).Cells
i = i + 1
wdCell.Range.Text = vaData(i, 1)
Next wdCell
'Save and close the document.
With wdDoc
.Save
.Close
End With
'Close the hidden instance of Microsoft Word.
wdApp.Quit
'Release the external variables from the memory
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "The data has been transfered to Test.docx.", vbInformation
End SubCell comments are often underused features of Excel. The following four utilities help you to get the most out of cell comments.
Submitted by Tommy Miles.
Excel allows the user to print the comments in a workbook, but it doesn’t specify the workbook or worksheet on which the comments appear, only the cell, as shown in Figure 14.1. The following sample places comments, author, and location of each comment on a new sheet for easy viewing, saving, or printing. Figure 14.2 shows sample results.
Sub ListComments()
Dim wb As Workbook
Dim ws As Worksheet
Dim cmt As Comment
Dim cmtCount As Long
cmtCount = 2
On Error Resume Next
Set ws = ActiveSheet
If ws Is Nothing Then Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWorksheet)
With wb.Sheets(1)
.Range("$A$1") = "Author"
.Range("$B$1") = "Book"
.Range("$C$1") = "Sheet"
.Range("$D$1") = "Range"
.Range("$E$1") = "Comment"
End With
For Each cmt In ws.Comments
With wb.Sheets(1)
.Cells(cmtCount, 1) = cmt.author
.Cells(cmtCount, 2) = cmt.Parent.Parent.Parent.Name
.Cells(cmtCount, 3) = cmt.Parent.Parent.Name
.Cells(cmtCount, 4) = cmt.Parent.Address
.Cells(cmtCount, 5) = CleanComment(cmt.author, cmt.Text)
End With
cmtCount = cmtCount + 1
Next
wb.Sheets(1).UsedRange.WrapText = False
Application.ScreenUpdating = True
Set ws = Nothing
Set wb = Nothing
End Sub
Private Function CleanComment(author As String, cmt As String) As String
Dim tmp As String
tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")
tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")
CleanComment = tmp
End FunctionSubmitted by Tom Urtis of San Francisco, California. Tom is the principal owner of Atlas Programming Management, an Excel consulting firm in the Bay Area.
Excel doesn’t automatically resize cell comments. And if you have several on a sheet, as shown in Figure 14.3, it can be a hassle to resize them one at a time. The following sample code resizes all the comment boxes on a sheet so that, when selected, the entire comment is easily viewable, as shown in Figure 14.4.
Sub CommentFitter1()
Application.ScreenUpdating = False
Dim x As Range, y As Long
For Each x In Cells.SpecialCells(xlCellTypeComments)
Select Case True
Case Len(x.NoteText) <> 0
With x.Comment
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 250 Then
y = .Shape.Width * .Shape.Height
.Shape.Width = 150
.Shape.Height = (y / 200) * 1.3
End If
End With
End Select
Next x
Application.ScreenUpdating = True
End SubThis sample resizes all the comment boxes on a sheet by centering the comments (see Figure 14.5).
Sub CommentFitter2()
Application.ScreenUpdating = False
Dim x As Range, y As Long
For Each x In Cells.SpecialCells(xlCellTypeComments)
Select Case True
Case Len(x.NoteText) <> 0
With x.Comment
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 250 Then
y = .Shape.Width * .Shape.Height
.Shape.ScaleHeight 0.9, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth 1#, msoFalse, msoScaleFromTopLeft
End If
End With
End Select
Next x
Application.ScreenUpdating = True
End SubA live chart cannot exist in a shape, but you can take a picture of the chart and load it into the comment shape, as shown in Figure 14.6.
The steps to do this manually are as follows:
Create/save the picture image you want the comment to display.
Create the comment, if you have not already done so, and select the cell in which the comment is.
From the Review ribbon, choose Edit Comment, or right-click the cell and select Edit Comment.
Right-click the comment border and select Format Comment.
Select the Colors and Lines tab, and click the down arrow belonging to the Color field of the Fill section.
Select Fill Effects, select the Picture tab, and then click the Select Picture button.
Navigate to your desired image, select it, and click OK twice.
The effect of having a “live chart” in a comment can be achieved if, for example, the code is part of a SheetChange event when the chart’s source data is being changed. Also, business charts are updated often, so you might want a macro to keep the comment updated and to avoid repeating the same steps. The following macro does just that: modifies the macro for file path name, chart name, destination sheet, and cell, and size of comment shape, depending on the size of the chart:
Sub PlaceGraph()
Dim x As String, z As Range
Application.ScreenUpdating = False
'assign a temporary location to hold the image
x = "C:XWMJGraph.gif"
'assign the cell to hold the comment
Set z = Worksheets("ChartInComment").Range("A3")
'delete any existing comment in the cell
On Error Resume Next
z.Comment.Delete
On Error GoTo 0
'select and export the chart
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Export x
'add a new comment to the cell, set the size and insert the chart
With z.AddComment
With .Shape
.Height = 322
.Width = 465
.Fill.UserPicture x
End With
End With
'delete the temporary image
Kill x
Range("A1").Activate
Application.ScreenUpdating = True
Set z = Nothing
End SubThe next four utilities will amaze and impress your clients.
Submitted by Ivan F. Moala of Auckland, New Zealand. Ivan is the site author of The XcelFiles (www.xcelfiles.com), where you will find out how to do things you thought you couldn’t do in Excel.
Conditional formatting is used to highlight the row and column of the active cell to help you visually locate it, as shown in Figure 14.7. Important: Do not use this method if you already have conditional formats on the worksheet. Any existing conditional formats will be overwritten. Also, this program clears the clipboard, so it is not possible to use while doing copy, cut, or paste.
Const iInternational As Integer = Not (0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer
'// On error resume in case
'// user selects a range of cells
On Error Resume Next
iColor = Target.Interior.ColorIndex
'// Leave On Error ON for Row offset errors
If iColor < 0 Then
iColor = 36
Else
iColor = iColor + 1
End If
'// Need this test in case font color is the same
If iColor = Target.Font.ColorIndex Then iColor = iColor + 1
Cells.FormatConditions.Delete
'// Horizontal color banding
With Range("A" & Target.Row, Target.Address) 'Rows(Target.Row)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
'// Vertical color banding
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & _
Target.Offset(-1, 0).Address)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
End SubThis example visually highlights the active cell without using conditional formatting when the keyboard arrow keys are used to move around the sheet.
Place the following in a standard module:
Dim strCol As String
Dim iCol As Integer
Dim dblRow As Double
Sub HighlightRight()
HighLight 0, 1
End Sub
Sub HighlightLeft()
HighLight 0, -1
End Sub
Sub HighlightUp()
HighLight -1, 0, -1
End Sub
Sub HighlightDown()
HighLight 1, 0, 1
End Sub
Sub HighLight(dblxRow As Double, iyCol As Integer, Optional dblZ As Double = 0)
On Error GoTo NoGo
strCol = Mid(ActiveCell.Offset(dblxRow, iyCol).Address, _
InStr(ActiveCell.Offset(dblxRow, iyCol).Address, "$") + 1, _
InStr(2, ActiveCell.Offset(dblxRow, iyCol).Address, "$") - 2)
iCol = ActiveCell.Column
dblRow = ActiveCell.Row
Application.ScreenUpdating = False
With Range(strCol & ":" & strCol & "," & dblRow + dblZ & ":" & dblRow + dblZ)
.Select
Application.ScreenUpdating = True
.Item(dblRow + dblxRow).Activate
End With
NoGo:
End Sub
Sub ReSet() 'manual reset
Application.OnKey "{RIGHT}"
Application.OnKey "{LEFT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
End SubPlace the following in the ThisWorkbook module:
Private Sub Workbook_Open()
Application.OnKey "{RIGHT}", "HighlightRight"
Application.OnKey "{LEFT}", "HighlightLeft"
Application.OnKey "{UP}", "HighlightUp"
Application.OnKey "{DOWN}", "HighlightDown"
Application.OnKey "{DEL}", "DisableDelete"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "{RIGHT}"
Application.OnKey "{LEFT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
Application.OnKey "{DEL}"
End SubSubmitted by Masaru Kaji.
You have a report where the data is set up in rows (see Figure 14.8), but you need the data formatted so each date and batch is in a single row, with the Value and Finish Position going across (Finish Position not shown in Figure 14.9). The following program does a customized data transposition based on the specified column, as shown in Figure 14.9.
Sub TransposeData()
Dim shOrg As Worksheet, shRes As Worksheet
Dim rngStart As Range, rngPaste As Range
Dim lngData As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("TransposeResult").Delete
Application.DisplayAlerts = True
On Error GoTo 0
On Error GoTo terminate
Set shOrg = Sheets("TransposeData")
Set shRes = Sheets.Add(After:=shOrg)
shRes.Name = "TransposeResult"
With shOrg
'--Sort
.Cells.CurrentRegion.Sort Key1:=.[B2], Order1:=1, Key2:=.[C2], Order2:=1, _
Key3:=.[E2], Order3:=1, Header:=xlYes
'--Copy title
.Rows(1).Copy shRes.Rows(1)
'--Set start range
Set rngStart = .[C2]
Do Until IsEmpty(rngStart)
Set rngPaste = shRes.Cells(shRes.Rows.Count, 1).End(xlUp).Offset(1)
lngData = GetNextRange(rngStart)
rngStart.Offset(, -2).Resize(, 5).Copy rngPaste
'Copy to V1 toV14
rngStart.Offset(, 2).Resize(lngData).Copy
rngPaste.Offset(, 5).PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
'Copy to V1FP to V14FP
rngStart.Offset(, 1).Resize(lngData).Copy
rngPaste.Offset(, 19).PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Set rngStart = rngStart.Offset(lngData)
Loop
End With
Application.Goto shRes.[A1]
With shRes
.Cells.Columns.AutoFit
.Columns("D:E").Delete shift:=xlToLeft
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
If MsgBox("Do you want to delete the original worksheet?", 36) = 6 Then
Application.DisplayAlerts = False
Sheets("TransposeData").Delete
Application.DisplayAlerts = True
End If
Set rngPaste = Nothing
Set rngStart = Nothing
Set shRes = Nothing
Exit Sub
terminate:
End Sub
Function GetNextRange(ByVal rngSt As Range) As Long
Dim i As Long
i = 0
Do Until rngSt.Value <> rngSt.Offset(i).Value
i = i + 1
Loop
GetNextRange = i
End FunctionOrdinarily, to deselect a single cell or range on a sheet, you must click an unselected cell to deselect all cells and then start over by reselecting all the correct cells. This is inconvenient if you need to reselect a lot of noncontiguous cells.
This sample adds two new options to the contextual menu of a selection: Deselect ActiveCell and Deselect ActiveArea. With the noncontiguous cells selected, hold down the Ctrl key, click the cell you want to deselect to make it active, release the Ctrl key, and then right-click the cell you want to deselect. The contextual menu shown in Figure 14.10 appears. Click the menu item that deselects either that one active cell or the contiguously selected area of which it is a part of.
Enter the following procedures in a standard module:
Sub ModifyRightClick()
'add the new options to the right-click menu
Dim O1 As Object, O2 As Object
'delete the options if they exist already
On Error Resume Next
With CommandBars("Cell")
.Controls("Deselect ActiveCell").Delete
.Controls("Deselect ActiveArea").Delete
End With
On Error GoTo 0
'add the new options
Set O1 = CommandBars("Cell").Controls.Add
With O1
.Caption = "Deselect ActiveCell"
.OnAction = "DeselectActiveCell"
End With
Set O2 = CommandBars("Cell").Controls.Add
With O2
.Caption = "Deselect ActiveArea"
.OnAction = "DeselectActiveArea"
End With
End Sub
Sub DeselectActiveCell()
Dim x As Range, y As Range
If Selection.Cells.Count > 1 Then
For Each y In Selection.Cells
If y.Address <> ActiveCell.Address Then
If x Is Nothing Then
Set x = y
Else
Set x = Application.Union(x, y)
End If
End If
Next y
If x.Cells.Count > 0 Then
x.Select
End If
End If
End Sub
Sub DeselectActiveArea()
Dim x As Range, y As Range
If Selection.Areas.Count > 1 Then
For Each y In Selection.Areas
If Application.Intersect(ActiveCell, y) Is Nothing Then
If x Is Nothing Then
Set x = y
Else
Set x = Application.Union(x, y)
End If
End If
Next y
x.Select
End If
End SubAdd the following procedures to the ThisWorkbook module:
Private Sub Workbook_Activate()
ModifyRightClick
End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars("Cell").Reset
End SubThe next ten utilities amaze me. In the various message board communities on the Internet, VBA programmers are constantly coming up with new ways to do something faster or better. When someone posts some new code that obviously runs circles around the prior generally accepted best code, everyone benefits.
Submitted by Tom Urtis.
A pivot table’s default behavior, when you’re double-clicking the data section, is to insert a new worksheet and display that drill-down information on the new sheet. The following example serves as an option for convenience, to keep the drilled-down recordsets on the same sheet as the pivot table (see Figure 14.11), and letting you delete them as you want. To use this macro, double-click the data section or the Totals section to create stacked drill-down recordsets in the next available row of this sheet. To delete any drill-down recordsets you’ve created, double-click anywhere in their respective current region.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Dim LPTR&
With ActiveSheet.PivotTables(1).DataBodyRange
LPTR = .Rows.Count + .Row - 1
End With
Dim PTT As Integer
On Error Resume Next
PTT = Target.PivotCell.PivotCellType
If Err.Number = 1004 Then
Err.Clear
If Not IsEmpty(Target) Then
If Target.Row > Range("A1").CurrentRegion.Rows.Count + 1 Then
Cancel = True
With Target.CurrentRegion
.Resize(.Rows.Count + 1).EntireRow.Delete
End With
End If
Else
Cancel = True
End If
Else
CS = ActiveSheet.Name
End If
Application.ScreenUpdating = True
End SubSubmitted by Juan Pablo González Ruiz of Bogotá, Colombia. Juan Pablo is the developer of the F&I Menu Wizard and handles all Spanish programming requests at MrExcel.com.
The following examples compare the runtimes of variations on changing the margins from the defaults to 1.5 inches and the footer/header to 1 inch in the Page Setup. The macro recorder was used to create Macro1. Macros 2, 3, and 4 show how the recorded code’s runtime can be decreased. Figure 14.12 shows the results of the speed test running each variation.
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 3/28/2007
'
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(1)
.RightMargin = Application.InchesToPoints(1)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(1)
.FooterMargin = Application.InchesToPoints(1)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -3
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = 1
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
End SubThe macro recorder is doing a lot of extra work, which requires extra processing time. Considering that, plus the fact that the PageSetup object is one of the slowest objects to update, and you can have quite a mess. So, a cleaner version (that uses just the Delete key!) follows:
Sub Macro1_Version2()
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(1.5)
.RightMargin = Application.InchesToPoints(1.5)
.TopMargin = Application.InchesToPoints(1.5)
.BottomMargin = Application.InchesToPoints(1.5)
.HeaderMargin = Application.InchesToPoints(1)
.FooterMargin = Application.InchesToPoints(1)
End With
End SubOkay, this runs faster than Macro1 (the average reduction is around 70 percent on some simple tests!), but it can be improved even further. As noted earlier, the PageSetup object takes a long time to process, so if you reduce the number of operations that VBA has to make and include some IF functions to update only the properties that require changing, you can get much better results.
In the following case, the Application.InchesToPoints function was hard-coded to the inches value. The third version of Macro1 looks like this:
Sub Macro1_Version3()
With ActiveSheet.PageSetup
If .LeftMargin <> 108 Then .LeftMargin = 108
If .RightMargin <> 108 Then .RightMargin = 108
If .TopMargin <> 108 Then .TopMargin = 108
If .BottomMargin <> 108 Then .BottomMargin = 108
If .HeaderMargin <> 72 Then .HeaderMargin = 72
If .FooterMargin <> 72 Then .FooterMargin = 72
End With
End SubYou should see the difference on this one when you’re not changing all the default margins.
Another option can reduce the runtime by more than 95 percent! It uses the PAGE.SETUP XLM method. The necessary parameters are left, right, top, bot, head_margin, and foot_margin. They are measured in inches, not points. So, using the same margins that we have been changing already, a fourth version of Macro1 looks like this:
Sub Macro1_Version4()
Dim St As String
St = "PAGE.SETUP(, , " & _
"1.5, 1.5, 1.5, 1.5" & _
", 0, False, False, False, 1, 1, True, 1, 1,False, , " & _
"1, 1" & _
", False)"
Application.ExecuteExcel4Macro St
End SubThe second and fourth lines of St correspond to these parameters. However, you need to follow some simple precautions. First, this macro relies on XLM language, which is still included in Excel for backward compatibility, but we don’t know when Microsoft will drop it. Second, be careful when setting the parameters of PAGE.SETUP because if one of them is wrong, the PAGE.SETUP is not executed and doesn’t generate an error, which can possibly leave you with the wrong page setup.
You may wonder how to calculate elapsed time down to the thousandth of a second, as shown earlier in Figure 14.12.
This is the code used to generate the time results for the macros in this section:
Public Declare Function QueryPerformanceFrequency _
Lib "kernel32" (lpFrequency As Currency) As Long
Public Declare Function QueryPerformanceCounter _
Lib "kernel32.dll" (lpPerformanceCount As Currency) As Long
Sub CalculateTime()
Dim Ar(1 To 20, 1 To 4) As Currency, WS As Worksheet
Dim n As Currency, str As Currency, fin As Currency
Dim y As Currency
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 1 To 4
For j = 1 To 20
Set WS = ThisWorkbook.Sheets.Add
WS.Range("A1").Value = 1
QueryPerformanceFrequency y
QueryPerformanceCounter str
Select Case i
Case 1: Macro1
Case 2: Macro1_Version2
Case 3: Macro1_Version3
Case 4: Macro1_Version4
End Select
QueryPerformanceCounter fin
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
n = (fin - str)
Ar(j, i) = CCur(Format(n, "##########.############") / y)
Next j
Next i
With Range("A1").Resize(1, 4)
.Value = Array("Macro1", "Macro2", "Macro3", " Macro4")
.Font.Bold = True
End With
Range("A2").Resize(20, 4).Value = Ar
With Range("A22").Resize(1, 4)
.FormulaR1C1 = "=AVERAGE(R2C:R21C)"
.Offset(1).FormulaR1C1 = "=RANK(R22C,R22C1:R22C4,1)"
.Resize(2).Font.Bold = True
End With
Application.ScreenUpdating = True
End SubSubmitted by Wei Jiang of Shiyan City, China. Jiang is a consultant for MrExcel.com.
By default, Excel enables you to sort lists numerically or alphabetically, but sometimes that is not what is needed. For example, a client might need each day’s sales data sorted by the default division order of belts, handbags, watches, wallets, and everything else. This sample uses a custom sort order list to sort a range of data into default division order. Figure 14.13 shows the results.
Sub CustomSort()
' add the custom list to Custom Lists
Application.AddCustomList ListArray:=Range("I1:I5")
' get the list number
nIndex = Application.GetCustomListNum(Range("I1:I5").Value)
' Now, we could sort a range with the custom list.
' Note, we should use nIndex + 1 as the custom list number here,
' for the first one is Normal order
Range("A2:C16").Sort Key1:=Range("B2"), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlSortColumns, _
OrderCustom:=nIndex + 1
Range("A2:C16").Sort Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlSortColumns
' At the end, we should remove this custom list...
Application.DeleteCustomList nIndex
End SubI have to admit, the new conditional formatting options in Excel, such as data bars, are fantastic. However, there still isn’t an option for a visual like that shown in Figure 14.14. The following example builds a progress indicator in Column C based on entries in Columns A and B.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 2 Or Target.Cells.Count > 1 Then Exit Sub
If Application.IsNumber(Target.Value) = False Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Numbers only please."
Exit Sub
End If
Select Case Target.Column
Case 1
If Target.Value > Target.Offset(0, 1).Value Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Value in column A may not be larger than value in column B."
Exit Sub
End If
Case 2
If Target.Value < Target.Offset(0, -1).Value Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Value in column B may not be smaller " & _
"than value in column A."
Exit Sub
End If
End Select
Dim x As Long
x = Target.Row
Dim z As String
z = Range("B" & x).Value - Range("A" & x).Value
With Range("C" & x)
.Formula = "=IF(RC[-1]<=RC[-2],REPT(""n"",RC[-1]) _
&REPT(""n"",RC[-2]-RC[-1]),REPT(""n"",RC[-2]) _
&REPT(""o"",RC[-1]-RC[-2]))"
.Value = .Value
.Font.Name = "Wingdings"
.Font.ColorIndex = 1
.Font.Size = 10
If Len(Range("A" & x)) <> 0 Then
.Characters(1, (.Characters.Count - z)).Font.ColorIndex = 3
.Characters(1, (.Characters.Count - z)).Font.Size = 12
End If
End With
End SubSubmitted by Daniel Klann of Sydney, Australia. Daniel works mainly with VBA in Excel and Access, but dabbles in all sorts of languages. He maintains a website at www.danielklann.com.
Using an input box for password protection has a major security flaw: The characters being entered are easily viewable. This program changes the characters to asterisks as they are entered—just like a real password field (see Figure 14.15).
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long,ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" _
Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam 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 Declare Function GetCurrentThreadId _
Lib "kernel32" () As Long
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
'Check for class name of the Inputbox
If Left$(strClassName, RetVal) = "#32770" Then
'Change the edit control to display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
Public Function InputBoxDK(Prompt, Optional Title, _
Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
On Error Resume Next
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function
Sub PasswordBox()
If InputBoxDK("Please enter password", "Password Required") <> "password" Then
MsgBox "Sorry, that was not a correct password."
Else
MsgBox "Correct Password! Come on in."
End If
End SubWord can change the case of selected text, but that capability is notably lacking in Excel. This program enables the Excel user to change the case of text in any selected range, as shown in Figure 14.16.
Sub TextCaseChange()
Dim RgText As Range
Dim oCell As Range
Dim Ans As String
Dim strTest As String
Dim sCap As Integer, _
lCap As Integer, _
i As Integer
'// You need to select a range to alter first!
Again:
Ans = Application.InputBox("[L]owercase" & vbCr & "[U]ppercase" & vbCr & _
"[S]entence" & vbCr & "[T]itles" & vbCr & "[C]apsSmall", _
"Type in a Letter", Type:=2)
If Ans = "False" Then Exit Sub
If InStr(1, "LUSTC", UCase(Ans), vbTextCompare) = 0 _
Or Len(Ans) > 1 Then GoTo Again
On Error GoTo NoText
If Selection.Count = 1 Then
Set RgText = Selection
Else
Set RgText = Selection.SpecialCells(xlCellTypeConstants, 2)
End If
On Error GoTo 0
For Each oCell In RgText
Select Case UCase(Ans)
Case "L": oCell = LCase(oCell.Text)
Case "U": oCell = UCase(oCell.Text)
Case "S": oCell = UCase(Left(oCell.Text, 1)) & _
LCase(Right(oCell.Text, Len(oCell.Text) - 1))
Case "T": oCell = Application.WorksheetFunction.Proper(oCell.Text)
Case "C"
lCap = oCell.Characters(1, 1).Font.Size
sCap = Int(lCap * 0.85)
'Small caps for everything.
oCell.Font.Size = sCap
oCell.Value = UCase(oCell.Text)
strTest = oCell.Value
'Large caps for 1st letter of words.
strTest = Application.Proper(strTest)
For i = 1 To Len(strTest)
If Mid(strTest, i, 1) = UCase(Mid(strTest, i, 1)) Then
oCell.Characters(i, 1).Font.Size = lCap
End If
Next i
End Select
Next
Exit Sub
NoText:
MsgBox "No text in your selection @ " & Selection.Address
End SubTypically, when you want to find certain values, text, or formulas in a range, the range is selected and each cell is tested. The following example shows how SpecialCells can be used to select only the desired cells. Having fewer cells to check will speed up your code:
Sub SpecialRange()
Dim TheRange As Range
Dim oCell As Range
Set TheRange = Range("A1:Z200").SpecialCells(__
xlCellTypeConstants, xlTextValues)
For Each oCell In TheRange
If oCell.Text = "Your Text" Then
MsgBox oCell.Address
MsgBox TheRange.Cells.Count
End If
Next oCell
End SubThere is no built-in menu for the right-click event of ActiveX objects on a sheet. This is a utility for that, using a command button for the example in Figure 14.17. Set the Take Focus on Click property of the command button to False.
Place the following in the ThisWorkbook module:
Private Sub Workbook_Open()
With Application
.CommandBars("Cell").Reset
.WindowState = xlMaximized
.Goto Sheet1.Range("A1"), True
End With
End Sub
Private Sub Workbook_Activate()
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application
.CommandBars("Cell").Reset
.WindowState = xlMaximized
.Goto Sheet1.Range("A1"), True
End With
ThisWorkbook.Save
End SubPlace the following in a standard module:
Sub MyRightClickMenu()
Application.CommandBars("Cell").Reset
Dim cbc As CommandBarControl
For Each cbc In Application.CommandBars("cell").Controls
cbc.Visible = False
Next cbc
With Application.CommandBars("Cell").Controls.Add(temporary:=True)
.Caption = "My Macro 1"
.OnAction = "Test1"
End With
With Application.CommandBars("Cell").Controls.Add(temporary:=True)
.Caption = "My Macro 2"
.OnAction = "Test2"
End With
With Application.CommandBars("Cell").Controls.Add(temporary:=True)
.Caption = "My Macro 3"
.OnAction = "Test3"
End With
Application.CommandBars("Cell").ShowPopup
End Sub
Sub Test1()
MsgBox "This is the Test1 macro from the ActiveX object's custom " & _
"right-click event menu.", , "''My Macro 1'' menu item."
End Sub
Sub Test2()
MsgBox "This is the Test2 macro from the ActiveX object's custom " & _
"right-click event menu.", , "''My Macro 2'' menu item."
End Sub
Sub Test3()
MsgBox "This is the Test3 macro from the ActiveX object's custom " & _
"right-click event menu.", , "''My Macro 3'' menu item."
End SubThese last samples are interesting applications that you might be able to incorporate into your own projects.
Submitted by Nathan P. Oliver.
The following retrieves the average of a valid ticker or the close of a fund for the specified date (see Figure 14.18).
Private Sub GetQuote()
Dim ie As Object, lCharPos As Long, sHTML As String
Dim HistDate As Date, HighVal As String, LowVal As String
Dim cl As Range
Set cl = ActiveCell
HistDate = cl(, 0)
If Intersect(cl, Range("C2:C" & Cells.Rows.Count)) Is Nothing Then
MsgBox "You must select a cell in column C."
Exit Sub
End If
If Not CBool(Len(cl(, -1))) Or Not CBool(Len(cl(, 0))) Then
MsgBox "You must enter a symbol and date."
Exit Sub
End If
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Navigate _
http://bigcharts.marketwatch.com/historical & _
"/default.asp?detect=1&symbol=" _
& cl(, -1) & "&close_date=" & Month(HistDate) & "%2F" & _
Day(HistDate) & "%2F" & Year(HistDate) & "&x=31&y=26"
Do While .Busy And .ReadyState <> 4
DoEvents
Loop
sHTML = .Document.body.innertext
.Quit
End With
Set ie = Nothing
lCharPos = InStr(1, sHTML, "High:", vbTextCompare)
If lCharPos Then HighVal = Mid$(sHTML, lCharPos + 5, 15)
If Not Left$(HighVal, 3) = "n/a" Then
lCharPos = InStr(1, sHTML, "Low:", vbTextCompare)
If lCharPos Then LowVal = Mid$(sHTML, lCharPos + 4, 15)
cl.Value = (Val(LowVal) + Val(HighVal)) / 2
Else: lCharPos = InStr(1, sHTML, "Closing Price:", vbTextCompare)
cl.Value = Val(Mid$(sHTML, lCharPos + 14, 15))
End If
Set cl = Nothing
End SubYou have a macro that moves data to a new workbook for the regional managers. What if you need to also copy macros to the new workbook? You can use Visual Basic for Application Extensibility to import modules to a workbook or to actually write lines of code to the workbook.
To use any of these examples, you must first open VB Editor, choose References from the Tools menu, and select the reference for Microsoft Visual Basic for Applications Extensibility 5.3. You must also trust access to VBA by going to the Developer ribbon, choosing Macro Security, and checking Trust Access to the VBA Project Object Model.
The easiest way to use VBA Extensibility is to export a complete module or userform from the current project and import it to the new workbook. Perhaps you have an application with thousands of lines of code. You want to create a new workbook with data for the regional manager and give her three macros to enable custom formatting and printing. Place all of these macros in a module called modToRegion. Macros in this module also call the frmRegion userform. The following code transfers this code from the current workbook to the new workbook:
Sub MoveDataAndMacro()
Dim WSD as worksheet
Set WSD = Worksheets("Report")
' Copy Report to a new workbook
WSD.Copy
' The active workbook is now the new workbook
' Delete any old copy of the module from C
On Error Resume Next
' Delete any stray copies from hard drive
Kill ("C:ModToRegion.bas")
Kill ("C:frmRegion.frm")
On Error GoTo 0
' Export module & form from this workbook
ThisWorkbook.VBProject.VBComponents("ModToRegion").Export _
("C:ModToRegion.bas")
ThisWorkbook.VBProject.VBComponents("frmRegion").Export ("C:frmRegion.frm")
' Import to new workbook
ActiveWorkbook.VBProject.VBComponents.Import ("C:ModToRegion.bas")
ActiveWorkbook.VBProject.VBComponents.Import ("C:frmRegion.frm")
On Error Resume Next
Kill ("C:ModToRegion.bas")
Kill ("C:frmRegion.bas")
On Error GoTo 0
End SubThe preceding method will work if you need to move modules or userforms to a new workbook. However, what if you need to write some code to the Workbook_Open macro in the ThisWorkbook module? There are two tools to use. The Lines method will allow you to return a particular set of code lines from a given module. The InsertLines method allows you to insert code lines to a new module.
Caution
With each call to InsertLines, you must insert a complete macro. Excel will attempt to compile the code after each call to InsertLines. If you insert lines that do not completely compile, Excel may crash with a general protection fault (GPF).
Sub MoveDataAndMacro()
Dim WSD as worksheet
Dim WBN as Workbook
Dim WBCodeMod1 As Object, WBCodeMod2 As Object
Set WSD = Worksheets("Report")
' Copy Report to a new workbook
WSD.Copy
' The active workbook is now the new workbook
Set WBN = ActiveWorkbook
' Copy the Workbook level Event handlers
Set WBCodeMod1 = ThisWorkbook.VBProject.VBComponents("ThisWorkbook") _
.CodeModule
Set WBCodeMod2 = WBN.VBProject.VBComponents("ThisWorkbook").CodeModule
WBCodeMod2.insertlines 1, WBCodeMod1.Lines(1, WBCodeMod1.countoflines)
End SubExcel 2007 offers fantastic new data-visualization tools, including data bars, color scales, icon sets, and improved conditional formatting rules. In Chapter 15, “Data Visualizations and Conditional Formatting,” you will learn how to automate the new tools and use VBA to invoke choices not available in the Excel user interface.