ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Discussion (Misc queries) (https://www.excelbanter.com/excel-discussion-misc-queries/)
-   -   SELECTION macro (https://www.excelbanter.com/excel-discussion-misc-queries/219253-selection-macro.html)

Gene Augustin
SELECTION macro
 
I have an old macro for quick selection of various areas of a spreadsheet. I
don't know where I got it or who authored it. It is saved in the Personal
Macro Workbook

It creates a new menu item SELECTION.

Some of it no longer works in Excel 2004 for MAC. It worked in the previous
MAC version of Excel.

All selections work except these:
Select Contiguous cells in active cell's column: fails
Select Contiguous cells in active cell's row: fails
Select an entire column: selects wrong
Select From the First NonBlank to the Last Nonblank in the Column: fails
SelectFirstToLastInColumn: fails

Perhaps someone can figure out what is wrong. This is an extreme time-saver
macro. Copy the macro and paste it into the Personal Macro Workbook (a
hidden workbook).

HERE IS THE ENTIRE MACRO:

Option Explicit

'NewMenuItem()
' Creates a new menu and adds menu items
Dim Cap(1 To 15)
Dim Mac(1 To 15)
Dim MenuName As String

MenuName = "&Selection"

Cap(1) = "Select Down (Like Ctrl+Shift+Down)"
Mac(1) = "SelectDown"
Cap(2) = "Select Up (Like Ctrl+Shift+Up)"
Mac(2) = "SelectUp"
Cap(3) = "Select To Right (Like Ctrl+Shift+Right)"
Mac(3) = " SelectToRight"
Cap(4) = "Select To Left (Like Ctrl+Shift+Right)"
Mac(4) = " SelectToLeft"
Cap(5) = "Select Current Region (Like Ctrl+Shift+*)"
Mac(5) = " SelectCurrentRegion"
Cap(6) = "Select Active Area (Like End, Home, Ctrl+Shift+Home)"
Mac(6) = " SelectActiveArea"
Cap(7) = "Select Contiguous Cells in ActiveCell's Column"
Mac(7) = " SelectActiveColumn"
Cap(8) = "Select Contiguous Cells in ActiveCell's Row"
Mac(8) = " SelectActiveRow"
Cap(9) = "Select an Entire Column (Like Ctrl+Spacebar)"
Mac(9) = " SelectEntireColumn"
Cap(10) = "Select an Entire Row (Like Shift+Spacebar)"
Mac(10) = " SelectEntireRow"
Cap(11) = "Select the Entire Worksheet (Like Ctrl+A)"
Mac(11) = " SelectEntireSheet"
Cap(12) = "Activate the Next Blank Cell Below"
Mac(12) = " ActivateNextBlankDown"
Cap(13) = "Activate the Next Blank Cell To the Right"
Mac(13) = " ActivateNextBlankToRight"
Cap(14) = "Select From the First NonBlank to the Last Nonblank in the
Row"
Mac(14) = " SelectFirstToLastInRow"
Cap(15) = "Select From the First NonBlank to the Last Nonblank in the
Column"
Mac(15) = " SelectFirstToLastInColumn"

On Error Resume Next
' Delete the menu if it already exists
MenuBars(xlWorksheet).Menus(MenuName).Delete

' Add the menu
MenuBars(xlWorksheet).Menus.Add Caption:=MenuName, befo="Help"

' Add the menu items
With MenuBars(xlWorksheet).Menus(MenuName).MenuItems
.Add Caption:=Cap(1), OnAction:=Mac(1)
.Add Caption:=Cap(2), OnAction:=Mac(2)
.Add Caption:=Cap(3), OnAction:=Mac(3)
.Add Caption:=Cap(4), OnAction:=Mac(4)
.Add Caption:="-"
.Add Caption:=Cap(5), OnAction:=Mac(5)
.Add Caption:=Cap(6), OnAction:=Mac(6)
.Add Caption:="-"
.Add Caption:=Cap(7), OnAction:=Mac(7)
.Add Caption:=Cap(8), OnAction:=Mac(8)
.Add Caption:="-"
.Add Caption:=Cap(9), OnAction:=Mac(9)
.Add Caption:=Cap(10), OnAction:=Mac(10)
.Add Caption:=Cap(11), OnAction:=Mac(11)
.Add Caption:="-"
.Add Caption:=Cap(12), OnAction:=Mac(12)
.Add Caption:=Cap(13), OnAction:=Mac(13)
.Add Caption:="-"
.Add Caption:=Cap(14), OnAction:=Mac(14)
.Add Caption:=Cap(15), OnAction:=Mac(15)
End With
End Sub

Sub Auto_Close()
Dim MenuName As String
MenuName = "&Selection"
' Delete the menu before closing
On Error Resume Next
MenuBars(xlWorksheet).Menus(MenuName).Delete
End Sub

Sub SelectDown()
Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub
Sub SelectUp()
Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub
Sub SelectToRight()
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub
Sub SelectToLeft()
Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub
Sub SelectCurrentRegion()
ActiveCell.CurrentRegion.Select
End Sub
Sub SelectActiveArea()
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub
Sub SelectActiveColumn()
If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Row 1
On Error Resume Next
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else
Set TopCell = ActiveCell.End(xlUp)
If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell
Else Set BottomCell = ActiveCell.End(xlDown)
Range(TopCell, BottomCell).Select

End Sub
Sub SelectActiveRow()
If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Column A
On Error Resume Next
If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else
Set LeftCell = ActiveCell.End(xlToLeft)
If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else
Set RightCell = ActiveCell.End(xlToRight)
Range(LeftCell, RightCell).Select
End Sub
Sub SelectEntireColumn()
Selection.EntireColumn.Select
End Sub
Sub SelectEntireRow()
Selection.EntireRow.Select
End Sub
Sub SelectEntireSheet()
Cells.Select
End Sub
Sub ActivateNextBlankDown()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub ActivateNextBlankToRight()
ActiveCell.Offset(0, 1).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
End Sub
Sub SelectFirstToLastInRow()
Set LeftCell = Cells(ActiveCell.Row, 1)
Set RightCell = Cells(ActiveCell.Row, 256)

If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select
Else Range(LeftCell, RightCell).Select
End Sub
Sub SelectFirstToLastInColumn()
Set TopCell = Cells(1, ActiveCell.Column)
Set BottomCell = Cells(16384, ActiveCell.Column)

If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select
Else Range(TopCell, BottomCell).Select
End Sub

Dave Peterson
SELECTION macro
 
This looks like it belongs to John Walkenbach:
http://spreadsheetpage.com/index.php...election_demo/

But I don't have a guess what's wrong unless you describe what fail means.

And since it's related to the Mac, you may find that you get more people to read
your question in this newsgroup:

news://msnews.microsoft.com/microsof...c.office.excel



Gene Augustin wrote:

I have an old macro for quick selection of various areas of a spreadsheet. I
don't know where I got it or who authored it. It is saved in the Personal
Macro Workbook

It creates a new menu item SELECTION.

Some of it no longer works in Excel 2004 for MAC. It worked in the previous
MAC version of Excel.

All selections work except these:
Select Contiguous cells in active cell's column: fails
Select Contiguous cells in active cell's row: fails
Select an entire column: selects wrong
Select From the First NonBlank to the Last Nonblank in the Column: fails
SelectFirstToLastInColumn: fails

Perhaps someone can figure out what is wrong. This is an extreme time-saver
macro. Copy the macro and paste it into the Personal Macro Workbook (a
hidden workbook).

HERE IS THE ENTIRE MACRO:

Option Explicit

'NewMenuItem()
' Creates a new menu and adds menu items
Dim Cap(1 To 15)
Dim Mac(1 To 15)
Dim MenuName As String

MenuName = "&Selection"

Cap(1) = "Select Down (Like Ctrl+Shift+Down)"
Mac(1) = "SelectDown"
Cap(2) = "Select Up (Like Ctrl+Shift+Up)"
Mac(2) = "SelectUp"
Cap(3) = "Select To Right (Like Ctrl+Shift+Right)"
Mac(3) = " SelectToRight"
Cap(4) = "Select To Left (Like Ctrl+Shift+Right)"
Mac(4) = " SelectToLeft"
Cap(5) = "Select Current Region (Like Ctrl+Shift+*)"
Mac(5) = " SelectCurrentRegion"
Cap(6) = "Select Active Area (Like End, Home, Ctrl+Shift+Home)"
Mac(6) = " SelectActiveArea"
Cap(7) = "Select Contiguous Cells in ActiveCell's Column"
Mac(7) = " SelectActiveColumn"
Cap(8) = "Select Contiguous Cells in ActiveCell's Row"
Mac(8) = " SelectActiveRow"
Cap(9) = "Select an Entire Column (Like Ctrl+Spacebar)"
Mac(9) = " SelectEntireColumn"
Cap(10) = "Select an Entire Row (Like Shift+Spacebar)"
Mac(10) = " SelectEntireRow"
Cap(11) = "Select the Entire Worksheet (Like Ctrl+A)"
Mac(11) = " SelectEntireSheet"
Cap(12) = "Activate the Next Blank Cell Below"
Mac(12) = " ActivateNextBlankDown"
Cap(13) = "Activate the Next Blank Cell To the Right"
Mac(13) = " ActivateNextBlankToRight"
Cap(14) = "Select From the First NonBlank to the Last Nonblank in the
Row"
Mac(14) = " SelectFirstToLastInRow"
Cap(15) = "Select From the First NonBlank to the Last Nonblank in the
Column"
Mac(15) = " SelectFirstToLastInColumn"

On Error Resume Next
' Delete the menu if it already exists
MenuBars(xlWorksheet).Menus(MenuName).Delete

' Add the menu
MenuBars(xlWorksheet).Menus.Add Caption:=MenuName, befo="Help"

' Add the menu items
With MenuBars(xlWorksheet).Menus(MenuName).MenuItems
.Add Caption:=Cap(1), OnAction:=Mac(1)
.Add Caption:=Cap(2), OnAction:=Mac(2)
.Add Caption:=Cap(3), OnAction:=Mac(3)
.Add Caption:=Cap(4), OnAction:=Mac(4)
.Add Caption:="-"
.Add Caption:=Cap(5), OnAction:=Mac(5)
.Add Caption:=Cap(6), OnAction:=Mac(6)
.Add Caption:="-"
.Add Caption:=Cap(7), OnAction:=Mac(7)
.Add Caption:=Cap(8), OnAction:=Mac(8)
.Add Caption:="-"
.Add Caption:=Cap(9), OnAction:=Mac(9)
.Add Caption:=Cap(10), OnAction:=Mac(10)
.Add Caption:=Cap(11), OnAction:=Mac(11)
.Add Caption:="-"
.Add Caption:=Cap(12), OnAction:=Mac(12)
.Add Caption:=Cap(13), OnAction:=Mac(13)
.Add Caption:="-"
.Add Caption:=Cap(14), OnAction:=Mac(14)
.Add Caption:=Cap(15), OnAction:=Mac(15)
End With
End Sub

Sub Auto_Close()
Dim MenuName As String
MenuName = "&Selection"
' Delete the menu before closing
On Error Resume Next
MenuBars(xlWorksheet).Menus(MenuName).Delete
End Sub

Sub SelectDown()
Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub
Sub SelectUp()
Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub
Sub SelectToRight()
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub
Sub SelectToLeft()
Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub
Sub SelectCurrentRegion()
ActiveCell.CurrentRegion.Select
End Sub
Sub SelectActiveArea()
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub
Sub SelectActiveColumn()
If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Row 1
On Error Resume Next
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else
Set TopCell = ActiveCell.End(xlUp)
If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell
Else Set BottomCell = ActiveCell.End(xlDown)
Range(TopCell, BottomCell).Select

End Sub
Sub SelectActiveRow()
If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Column A
On Error Resume Next
If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else
Set LeftCell = ActiveCell.End(xlToLeft)
If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else
Set RightCell = ActiveCell.End(xlToRight)
Range(LeftCell, RightCell).Select
End Sub
Sub SelectEntireColumn()
Selection.EntireColumn.Select
End Sub
Sub SelectEntireRow()
Selection.EntireRow.Select
End Sub
Sub SelectEntireSheet()
Cells.Select
End Sub
Sub ActivateNextBlankDown()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub ActivateNextBlankToRight()
ActiveCell.Offset(0, 1).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
End Sub
Sub SelectFirstToLastInRow()
Set LeftCell = Cells(ActiveCell.Row, 1)
Set RightCell = Cells(ActiveCell.Row, 256)

If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select
Else Range(LeftCell, RightCell).Select
End Sub
Sub SelectFirstToLastInColumn()
Set TopCell = Cells(1, ActiveCell.Column)
Set BottomCell = Cells(16384, ActiveCell.Column)

If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select
Else Range(TopCell, BottomCell).Select
End Sub

--

Dave Peterson


All times are GMT +1. The time now is 08:22 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com