Writing the Code

Now that the dialog is created, we can start writing the code.

In the basMain standard module, place the code that displays the Select Special dialog box. However, it is possible that the current selection in the active worksheet is not a collection of cells. It could be a drawing object or chart, for instance. In this case, we want to issue a message stating that the current selection is inappropriate for the SelectSpecial utility and not to bother displaying the dialog. The code in Example 19-2 (which should be stored in basMain) will do the job.

Example 19-2. The SelectSpecial Procedure

Sub SelectSpecial()

' Check for valid selection If TypeName(Selection) <> "Range" Then

MsgBox "Selection must be a range of worksheet cells.", vbCritical Else dlgSelectSpecial.Show End If End Sub

Note that we use the TypeName function. When applied to an object, as in:

TypeName(ObjectVariable)

the function will return the name of the object.

Next, we need a couple of module-level declarations, shown in Example 19-3, in the form's code module.

Example 19-3. dlgSelectSpecial Module-Level Declarations

Option Explicit

' These are used by more than one procedure Dim rngSearch As Range Dim rngForUndo As Range

The Initialize event of the form is the place to initialize the controls. As Example 19-4 shows, we first want to disable some command buttons and fill the lblSearchRange label. We also can set the module-level variables here.

Example 19-4. The Initialize Event Procedure

Private Sub UserForm Initialize() cmdSelect.Enabled = False cmdUndo.Enabled = False lblSearchRange.Caption = "Search Range: Nothing"

Set rngSearch = Selection Set rngForUndo = rngSearch End Sub

The Close button simply unloads the form; its source code is shown in Example 19-5. Example 19-5. The cmdClose_Click Event Procedure

Private Sub cmdClose Click()

Unload Me End Sub

Incidentally, you can test out your progress so far (and later) by running the Initialize event. Just place the cursor in this event and hit F5.

The Undo button returns the selection to its original state, which is saved in the module-level variable rngForUndo. Its source code is shown in Example 19-6.

Example 19-6. The cmdUndo_Click Event Procedure

Private Sub cmdUndo Click()

If Not rngForUndo Is Nothing Then rngForUndo.Select cmdUndo.Enabled = False End If End Sub

The first thing the user will do after the dialog is displayed is choose an option from the frame at the top. This choice will determine in part the search range. Also, some choices require a more restrictive search range. To react to the user's choice, we call a procedure called GetSearchRange whenever an option button is selected. The code to handle the option buttons is shown in Example 19-7.

Example 19-7. Event Handlers for the Option Buttons

Private Sub optDifferent Click()

GetSearchRange End Sub

Private Sub optEmpty Click()

GetSearchRange End Sub

Private Sub optNotEmpty Click()

GetSearchRange End Sub

Private Sub optSame Click()

GetSearchRange End Sub

The GetSearchRange procedure is shown in Example 19-8. Example 19-8. The GetSearchRange Procedure

Private Sub GetSearchRange()

' Set search range based on choice of search type.

' If Different or Same, validate range

' If single cell, change to:

' - used column for Different or Same match ' - used range for Empty or Not Empty match

' We know that rngSearch is a range of cells.

' Disables Select button if not a valid range.

Dim cColumns As Integer, cRows As Integer cmdSelect.Enabled = True ' May be temporary

If optDifferent Or optSame Then

' Search range must be (portion of) ' a single row or column cColumns = rngSearch.Columns.Count cRows = rngSearch.Rows.Count

If rngSearch.Areas.Count > 1 Or

(cColumns <> 1 And cRows <> 1) Then lblSearchRange.Caption = "Requires (portion of) single column or row."

cmdSelect.Enabled = False Exit Sub End If

' If single cell then expand to used portion of column If cColumns = 1 And cRows = 1 Then

Set rngSearch = Application.Intersect( rngSearch.EntireColumn, ActiveSheet.UsedRange) End If

ElseIf optEmpty Or optNotEmpty Then

' If selection is single cell then expand to used range If rngSearch.Cells.Count = 1 Then

Set rngSearch = ActiveSheet.UsedRange End If End If lblSearchRange.Caption = "Search Range: " &

rngSearch.Address(RowAbsolute:=False, ColumnAbsolute:=False) End Sub

When the user hits the Select button, the action begins, based on the user's selection. Thus, we should call a different procedure based on which option button is selected. After the new selection is made, the Select button is disabled. Since the CompleteRows and CompleteColumns features are still available, however, we do not want to dismiss the main dialog. The code to handle the Select button is shown in Example 19-9.

Example 19-9. The cmdSelect_Click Event Procedure

Private Sub cmdSelect Click() ' Read option buttons and ' call appropriate procedure

If optDifferent Then SelectIfDifferent ElseIf optSame Then

SelectIfSame ElseIf optEmpty Then

SelectIfEmpty ElseIf optNotEmpty Then

SelectIfNotEmpty End If cmdSelect.Enabled = False End Sub

The SelectIfDifferent procedure is shown in Example 19-10. It basically searches through the rngSearch range, looking for cells whose contents differ from the previous cell. Since we do not know whether the range is a column or row (or portion thereof), it is easier to use a double For loop. However, it would be a bit more efficient to split the code into two cases (cColumns = 1 and cRows = 1). Note that the first cell needs a bit of special attention, since we want to include it in the selection. The selection is accumulated in a Range object variable called rngMatch, using the Union function. However, we always need to consider the possibility that rngMatch is currently equal to Nothing, in which case the Union function will (unfortunately) return Nothing. In other words:

Application.Union(Something, Nothing) = Nothing

Example 19-10. The SelectIfDifferent Procedure

Private Sub SelectIfDifferent() Dim rngMatch As Range Dim vCellValue As Variant Dim vPreviousCellValue As Variant Dim cMatches As Integer Dim oCell As Object

Dim cRows As Integer, cColumns As Integer Dim r As Integer, c As Integer

' Get row and column count (one of which is 1) cColumns = rngSearch.Columns.Count cRows = rngSearch.Rows.Count

' Start search cMatches = 0

Set rngMatch = Nothing

For c = 1 To cColumns

Set oCell = rngSearch.Cells(r, c) vCellValue = oCell.Value vCellValue = CStr(vCellValue)

If r = 1 And c = 1 Then ' Include first cell If rngMatch Is Nothing Then

Set rngMatch = oCell Else

Set rngMatch = Application.Union(rngMatch, oCell) End If cMatches = cMatches + 1 ' Save value for next comparison vPreviousCellValue = vCellValue Else

' Do comparison with previous cell vCellValue = rngSearch.Cells(r, c).Value vCellValue = CStr(vCellValue)

If vCellValue <> vPreviousCellValue Then If rngMatch Is Nothing Then

Set rngMatch = oCell Else

Set rngMatch = Application.Union(rngMatch, oCell) End If cMatches = cMatches + 1 End If

' Save value for next comparion vPreviousCellValue = vCellValue End If Next ' column

Tea287 ly®

Next ' row

' Select the range If cMatches > 0 Then rngMatch.Select cmdUndo.Enabled = False Else

MsgBox "No matching cells. Selection will not be changed.", vbInformation cmdUndo.Enabled = False End If End Sub

The SelectlfSame procedure, which is shown in Example 19-11, is very similar to the SelectlfDifferent procedure. One significant difference is that we do not include the first cell.

Example 19-11. The SelectIfSame Procedure

Private Sub SelectIfSame()

Dim rngMatch As Range

Dim vCellValue As Variant

Dim vPreviousCellValue As Variant

Dim cMatches As Integer

Dim oCell As Object

Dim cRows As Integer, cColumns As Integer Dim r As Integer, c As Integer

' Get row and column count (one of which is 1) cColumns = rngSearch.Columns.Count cRows = rngSearch.Rows.Count

' Start search cMatches = 0

Set rngMatch = Nothing

For c = 1 To cColumns

Set oCell = rngSearch.Cells(r, c) vCellValue = oCell.Value vCellValue = CStr(vCellValue)

' Save first value for next comparion vPreviousCellValue = vCellValue Else

' Do comparison with previous cell vCellValue = rngSearch.Cells(r, c).Value vCellValue = CStr(vCellValue) If vCellValue = vPreviousCellValue Then If rngMatch Is Nothing Then

Set rngMatch = oCell Else

Set rngMatch = Application.Union(rngMatch, oCell) End If cMatches = cMatches + 1 End If

' Save value for next comparion vPreviousCellValue = vCellValue End If Next ' column Next ' row

' Select the range If cMatches > 0 Then rngMatch.Select cmdUndo.Enabled = False Else

MsgBox "No matching cells. Selection will not be changed.", vbInformation cmdUndo.Enabled = False End If

End Sub

The SelectIfEmpty and SelectIfNotEmpty procedures are almost identical. SelectIfEmpty is shown in Example 19-12.

Example 19-12. The SelectIfEmpty Procedure

Private Sub SelectIfEmpty() Dim rngMatch As Range Dim cMatches As Integer Dim oCell As Object

Dim cRows As Integer, cColumns As Integer Dim r As Integer, c As Integer

' Get row and column count (one of which is 1) cColumns = rngSearch.Columns.Count cRows = rngSearch.Rows.Count

' Start search cMatches = 0

Set rngMatch = Nothing

For c = 1 To cColumns

Set oCell = rngSearch.Cells(r, c) If IsEmpty(oCell) Then

If rngMatch Is Nothing Then

Set rngMatch = oCell Else

Set rngMatch = Application.Union(rngMatch, oCell) End If cMatches = cMatches + 1 End If

Next ' column Next ' row

' Select the range If cMatches > 0 Then rngMatch.Select cmdUndo.Enabled = False Else

MsgBox "No matching cells. Selection will not be changed.", vbInformation cmdUndo.Enabled = False

End If End Sub

To get the SelectIfNotEmpty procedure, just change the line:

If IsEmpty(oCell) Then to:

If Not IsEmpty(oCell) Then

Finally, the CompleteColumns and CompleteRows procedures are called from the corresponding command-button Click events and are very similar. CompleteColumns is shown in Example 19-13.

Example 19-13. The cmdCompleteColumns_Click Procedure

Private Sub cmdCompleteColumns Click()

' For each selected cell, select the entire column

Dim oCell As Object Dim rngNew As Range

Set rngNew = Nothing

For Each oCell In Selection If rngNew Is Nothing Then

Set rngNew = oCell.EntireColumn Else

Set rngNew = Union(rngNew, oCell.EntireColumn) End If Next rngNew.Select cmdUndo.Enabled = True End Sub

To get CompleteRows, just replace EntireColumn by EntireRow in two places.

0 0

Post a comment