Main Page 
 MS Excel
 St. Louis 

Assorted Code Cuts

I have been adding a lot of whole programs so I thought this was a good time to drop back to basics and show how I do some little stuff. This is a start, more to come shortly.

UnProtect - Do Processing - Re-Protect

So you have a password on some cells. You need to sort or something in your code but your users should not be able to move things around. Somewhere near the top, you what to define the password like

Dim pW2 as String

	ActiveSheet.Unprotect password:=pW2	'Remove protection
		{some more code goes here}
	ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
        :=True, password:=pW2			'Re-protect

Save without Asking Permission

I am frequently asked about Excel stopping to ask permission to save, delete, etc..

	Application.DisplayAlerts = False	'Turn off before saving
  	ActiveWorkbook.SaveAs filename:="C:\DATA\myfile.XLS", _
	Application.DisplayAlerts = True  	'Turn on so important messages display

Open a Dialog to Request a File

Recently had a case where a vital file would be on a network and it might be a different path for everyone. This example opens the dialog, asking for the file by name, and lets the user point to the directory where it is located.   (added 01/20/2001)

    Application.Dialogs(xlDialogOpen).Show "Masterre.XLS"  'Get the Master
    On Error GoTo ErHandles     'Handles MASTER not open

Message Box and Save

Pulled out all the stops on this last project. Wanted to give the user the option of saving at the end of the run with a Suggested name..   (added 01/20/2001)

SaveBox = MsgBox("Would you like to save this file now? If you answer OK," _
	"a name will be suggested.", _
         vbOKCancel, "Save File...")	'Ask Question, choice of controls, Title
    If SaveBox = vbOK Then
        Application.Dialogs(xlDialogSaveAs).Show SuggName	'Show name from other 
    End If

Here is where I suggested a name

SuggName = "1120 Long " & Left(Sheets("Practical Stuff").Range("D4"), 5) _
	& Application.Text(Now(), "mmdd") & ".XLS"	'Build a suggested file name

Generate a Formula from VBA

Sometimes you want to generate a function to be included on the page. You need the range of cells expressed as an address. The example below comes out to something like =AVERAGE($D$6:$D$40).   (added 01/20/2001)

        Cells(Stone + 1, 7) = "=AVERAGE(" & Range(Cells(6, 7), _
	 Cells(Stone - 1, 7)).Address & ")"

Run Multiple Routines

In the big macro I am pulling all these little routines from, I have sections that are ‘traffic cops’ and run all the little re-usable routines. See how the following has so many lines the Run Macro.

Sub BasicReport()
    GetText         'Run macro
    ThePath = "C:\Data\Stuff\"
    ComName = ThePath & RptName & ".XLS"
    ActiveWorkbook.SaveAs filename:=ComName, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    LastRow = Application.CountA(ActiveSheet.Range("A:A"))
    MailCol = 1         'If Mailing
    ListType = "ABC Phone List"
    SortRoutine     'Run macro
    For Q = 1 To LastRow
        If Left(Cells(Q, 1), 2) = "MC" Then     'Convert MC in anticipation of Mixed Case
            Cells(Q, 1).Value = "MC " & Right(Cells(Q, 1), _
	    Len(Cells(Q, 1)) - 2)
        End If
    ContractorFx    'Contractor & Phone
    CharOpts           'Run macro
    FixMonths           'Run macro
    ColorRows           'Run macro
    RemoveCols          'Run macro
    SetPrint            'Run macro
    MailOpts        'Determine whether to mail or not
End Sub


My Favorite Instructions

I have a spreadsheet I keep constantly available where I have entered my most commonly used instructions, you may recognize some of these. I liked it so much that I printed it (along with an Excel color chart) and it is at home and office.

Code Explanation
CurrActiveSheet = ActiveWorkbook.Name             
Get the name of the active workbook
Selection.NumberFormat = "### ###-####" 
LastRow = Application.CountA(ActiveSheet.Range("M:M"))
Get row number of last contiguous cell in column
Windows("Phone List.xls").Activate
Select a workbook other than the one you are working in
ActiveSheet.Range(Cells(2, 9), Cells(BotRange, 11)).Select
Select a range of cells
BottomRw = ActiveCell.SpecialCells(xlLastCell).Row
Get the row number of the last used cell
Pather = ThisWorkbook.Path & "\"
Application.Union(Cells(i, 1), Cells(i, 10), Cells(i, 4)).Select 
Use to select a group of non-adjacent cells
Copy the cells
Paste them in the location on the current sheet
Application.ScreenUpdating = True
Turn screen updating back on a conclusion; FALSE prevents that annoying flashing around.
Application.StatusBar = "Done"
Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12)).Select
sTab7 = DialogSheets("dlgTabber").EditBoxes("Edit Box 17").Text
Grab what is in Edit Box 17
Cells(Q, 1).Select
MsgBox ("That's all folks",64)
Let the world know you are finished.
Option Explicit Forces you to DIM all variable before using them. Keeps you honest

Updated:  20 October 2001 12:59:14