Allowing the user to pick a cell in excel

Allowing the user to pick a cell in excel

• Jessica Alba

  Thanks Derek!

  It solved one of my issues. However one is left and that is. I would need to find which row and column the picked cell is located in as in the example below, see red colored.

  ActiveSheet.Select
  Range("A1:U1000").Select
  y = Selection

  Dim row_disp, column_disp
  
  For j = column To column + 1
  For i = row To size_row
  w = y(i, j)
  If w = "Displ. [mm]" Then row_disp = i
  If w = "Displ. [mm]" Then column_disp = j
  If w = "Displ. [mm]" Then GoTo End_loop1
  Next i
  Next j
  End_loop1:
  

  Do you know how I can get this data from myRange in your reply

  Thankful for help

  \Jonas

  
  
  

• sham_huss

  Jonas,

  The user selection thats selected using the InputBox is a Range object, the range object has Row and Column properties which I hope is the what your looking for.

  'selects the cell and returns the value of that cell
  Dim myRange As Range
  Set myRange = Application.InputBox(prompt:="Select the cell containing the data you want.", Type:=8)
  If myRange Is Nothing Then
  'cancel pressed
  Else
  MsgBox myRange.Row
  MsgBox myRange.Column
  End If

  There was a small error in the original posted code (If Not myRange is Nothing should have been If myRange is Nothing)

  
  
  

• Janson103464

  Hi, I think giving you my utility file is more helpful. I am kind of too lazy to look into the whole thing. Basically this utility file give you all the example of some useful stuff.

  The first is called Utility class, second called Utility_Move class. Hope this clear most of stuff you are not sure of.

  ' ======================== For Starter ========================
  ' For starter who is not experenced with Excel VBA, please read.
  ' You need to know the basics of VBA. Here is the list of things you should know.

  ' Hints.
  ' Use Record if you don't know what function you can use to do certain operations
  ' that you can do manually.

  ' Last Resort.
  ' Application.SendKeys will explicitly send key strokes.
  ' Application.SendKeys "+abc{Enter}" means, typing Abc and Enter.
  ' Sample: Better to follow this, or you will have problems.
  ' With ThisWorkbook.Worksheets("Sheet1")
  ' .Activate
  ' .Cells(1, 1).Select
  ' SendKeys "{F2}TEST~", True
  ' .Cells(1, 1).Copy
  ' .Cells(2, 2).PasteSpecial Paste:=xlPasteValues
  ' End With
  ' MsgBox "macro1"

  ' Range Objects.
  ' ActiveCell, CurrentRegion, Cells(), Range(), Selection are Range objects, but ActiveCell only contains one address
  ' Range("A1").select will select the first cell
  ' Range("A1:C1, E1").select will select Cells from A1 to C1, and E1 separately.
  ' Cells.Select will select everything in the sheet
  ' Cells(5, 2).select will select "B5"
  ' Cells(5, "B").select will select "B5"
  ' ActiveCell.CurrentRegion.select will select the whole area current cell located in.

  ' Cell Info.
  ' Use ActiveCell.FormulaR1C1 to get the formula.
  ' Use ActiveCell.Value to get value of formated formula. When copy value, format is copied as well.
  ' Use 123<=>ABC Converter when you want to convert ActiveCell.Column to ABC format, and vice versa.

  ' ======================== For Everyone ========================
  ' You need to include References: Microsoft Scripting Runtime
  ' This is because Scripting.FileSystemObject is included for easier access.
  ' You must include Utility_Move along with this code object.
  ' Also public member Go will provide you with Utility_Move functionalities.
  ' Please refer those functionalities to Utility_Move class.
  ' Function name should be self-explainatory.
  ' Play around it to see how they work.
  Option Explicit

  Public fso As Scripting.FileSystemObject
  Public Go As Utility_Move

  Dim Column(26) As String
  Dim i As Long
  Private Sub Class_Initialize()
  Set fso = New Scripting.FileSystemObject
  Set Go = New Utility_Move
  
  For i = 0 To 25
  Column(i) = Chr(i + 65)
  Next
  End Sub

  ' ============================= 123<=>ABC Converter ============================
  Function ABCToNumber(columnString As String) As Long
  Dim length As Long, result As Long
  Dim characterIndex As Long
  length = Len(columnString)
  result = 0
  Dim i
  For i = 1 To length
  ' index one character
  characterIndex = Asc(Mid(columnString, length - i + 1, 1)) - 64
  ' convert to the index of current digit
  characterIndex = characterIndex * (26 ^ (i - 1))
  ' commit to result
  result = result + characterIndex
  Next
  ABCToNumber = result
  End Function

  Function NumberToABC(columnLong As Long) As String
  Dim reminder As Long, result As String
  result = ""
  Do Until columnLong / 26 < 1
  reminder = columnLong Mod 26
  result = Column(reminder - 1) + result
  columnLong = columnLong / 26
  Loop
  reminder = columnLong Mod 26
  result = Column(reminder - 1) + result
  NumberToABC = result
  End Function

  ' =============================String Token============================
  ' chr(34) = "
  Function Peek(text As String, Optional stopBy As String = ",", Optional delimiter As String = "chr(34)") As String
  Dim tempText As String
  tempText = Left(text, Len(text))
  Peek = NextToken(tempText, stopBy, delimiter)
  End Function

  Function NextToken(ByRef text As String, Optional stopBy As String = ",", Optional delimiter As String = "chr(34)") As String
  If delimiter = "chr(34)" Then delimiter = Chr(34)
  
  Dim skipStopBy As Boolean
  skipStopBy = False
  NextToken = ""
  Do Until Left(text, Len(stopBy)) = stopBy And Not skipStopBy
  If Left(text, Len(delimiter)) = delimiter Then
  If skipStopBy = True Then
  skipStopBy = False
  Else
  skipStopBy = True
  End If
  End If
  
  If Left(text, Len(stopBy)) = stopBy Then
  NextToken = NextToken + Left(text, Len(stopBy))
  text = Right(text, Len(text) - Len(stopBy))
  Else
  NextToken = NextToken + Left(text, 1)
  text = Right(text, Len(text) - 1)
  End If
  
  If Len(text) < 1 Then GoTo Final_Step
  Loop
  text = Right(text, Len(text) - 1)
  Final_Step:
  If Left(NextToken, 1) = delimiter And Right(NextToken, 1) = delimiter Then NextToken = Mid(NextToken, 2, Len(NextToken) - 2)
  End Function

  Function PeekFixedWidth(text As String, width As Long) As String
  PeekFixedWidth = Left(text, width)
  End Function

  Function NextTokenFixedWidth(ByRef text As String, width As Long) As String
  NextTokenFixedWidth = PeekFixedWidth(text, width)
  text = Right(text, Len(text) - width)
  End Function

  ' =============================Selection============================
  ' This is obsolete because RegionPoints provide much more flexibility.
  Sub SelectRegion(Optional Column As Integer = 0, Optional Row As Integer = 0, Optional Position As String = "A1")
  Dim tbl
  Set tbl = Range(Position).CurrentRegion
  If (Column > 0) Then Set tbl = tbl.Offset(0, Column).Resize(tbl.Rows.Count, tbl.Columns.Count - Column + 1)
  If (Row > 0) Then Set tbl = tbl.Offset(Row, 0).Resize(tbl.Rows.Count - Row + 1, tbl.Columns.Count)
  tbl.Select
  End Sub

  ' After Obtain region points, you can select the cell and move them around to the desire position.
  ' Then, simply use Range(cellAddress1 +":"+ cellAddrees2).select to select desired area.
  Sub RegionPoints(ByRef TopLeft_Row As Long, ByRef TopLeft_Column As Long, _
  ByRef BottomRight_Row As Long, ByRef BottomRight_Column As Long, Optional Position As String)
  Dim tbl As Range
  If Position = "" Then
  Set tbl = Range(CellAddress).CurrentRegion
  Else
  Set tbl = Range(Position).CurrentRegion
  End If
  Dim address As String, allAddress As String
  allAddress = tbl.address
  
  If allAddress <> "" Then
  address = NextToken(allAddress, ":")
  TopLeft_Row = CLng(CellRow(address))
  TopLeft_Column = ABCToNumber(CellColumn(address))
  Else
  TopLeft_Row = 0
  TopLeft_Column = 0
  End If
  
  If allAddress <> "" Then
  address = NextToken(allAddress, ":")
  BottomRight_Row = CLng(CellRow(address))
  BottomRight_Column = ABCToNumber(CellColumn(address))
  Else
  BottomRight_Row = TopLeft_Row
  BottomRight_Column = TopLeft_Column
  End If
  End Sub

  ' This will find the boundary of the whole data sheet.
  ' Meaning boundary is combination of all regions, not just one region.
  Sub DocumentPoints(ByRef TopLeft_Row As Long, ByRef TopLeft_Column As Long, _
  ByRef BottomRight_Row As Long, ByRef BottomRight_Column As Long)
  Dim Temp As Range
  Set Temp = ActiveCell
  FirstRowCell
  TopLeft_Row = ActiveCell.Row
  FirstColumnCell
  TopLeft_Column = ActiveCell.Column
  LastRowCell
  BottomRight_Row = ActiveCell.Row
  LastColumnCell
  BottomRight_Column = ActiveCell.Column
  Temp.Select
  End Sub

  Sub FirstRowCell()
  Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), LookIn:=xlFormulas, LookAt:= _
  xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
  , SearchFormat:=False).Activate
  End Sub
  Sub FirstColumnCell()
  Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), LookIn:=xlFormulas, LookAt:= _
  xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
  , SearchFormat:=False).Activate
  End Sub
  Sub LastRowCell()
  Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), LookIn:=xlFormulas, LookAt:= _
  xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
  , SearchFormat:=False).Activate
  End Sub
  Sub LastColumnCell()
  Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), LookIn:=xlFormulas, LookAt:= _
  xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
  , SearchFormat:=False).Activate
  End Sub

  
  ' will not function correctly if the currently selection
  ' does not have more items to the direction
  Function SelectTo(Direction As emMove, Optional times As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Dim address As String
  address = CellAddress
  SelectTo = Go.Move(Direction, Steps:=times, SkipHidden:=SkipHidden)
  Range(address, Selection).Select
  Range(address).Activate
  End Function

  ' =============================Cell Info============================
  ' Use ActiveCell.Address if parameter is not present
  Function CellColumn(Optional UnparsedAddress As String) As String
  Dim Temp
  If UnparsedAddress = "" Then
  Temp = Split(ActiveCell.address, "$", -1, vbBinaryCompare)
  Else
  Temp = Split(UnparsedAddress, "$", -1, vbBinaryCompare)
  End If
  CellColumn = Temp(1)
  End Function
  Function CellRow(Optional UnparsedAddress As String) As String
  Dim Temp
  If UnparsedAddress = "" Then
  Temp = Split(ActiveCell.address, "$", -1, vbBinaryCompare)
  Else
  Temp = Split(UnparsedAddress, "$", -1, vbBinaryCompare)
  End If
  CellRow = Temp(2)
  End Function
  Function CellAddress(Optional UnparsedAddress As String) As String
  CellAddress = CellColumn(UnparsedAddress) + CellRow(UnparsedAddress)
  End Function

  'File Name and Folder Name related to current cell
  Function CellFileRoot() As String
  CellFileRoot = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.name) - 1)
  End Function
  Function CellFileName() As String
  CellFileName = ActiveWorkbook.name
  End Function

  ' Spaces in the cell count treated as Empty
  Function CellIsEmpty() As Boolean
  CellIsEmpty = (Trim(ActiveCell.FormulaR1C1) = "")
  End Function
  Function RowIsEmpty() As Boolean
  Dim addr As String
  addr = CellAddress
  Range("A" + CellRow).Select
  RowIsEmpty = Not (Go.RightMost)
  Range(addr).Select
  End Function
  Function ColumnIsEmpty() As Boolean
  Dim addr As String
  addr = CellAddress
  Range(CellColumn + "1").Select
  ColumnIsEmpty = Not (Go.UpMost)
  Range(addr).Select
  End Function
  Function SheetIsEmpty(Optional SpaceAsEmpty As Boolean = True) As Boolean
  If SpaceAsEmpty Then
  Dim addr As String
  addr = CellAddress
  SheetIsEmpty = Not Find("*")
  Do Until SheetIsEmpty = True Or addr = CellAddress
  If Trim(ActiveCell.FormulaR1C1) <> "" Then SheetIsEmpty = False: Exit Function
  SheetIsEmpty = Not Find("*")
  Loop
  SheetIsEmpty = True
  Else
  SheetIsEmpty = Not Find("*")
  End If
  End Function

  ' Font Operation
  ' No Para = Get. Has Para = Set.
  Function Color(Optional colorIndex As Integer) As Integer
  If colorIndex = 0 Then
  Color = Selection.Font.colorIndex
  Else
  Selection.Font.colorIndex = colorIndex
  Color = colorIndex
  End If
  End Function

  ' =============================Range Op============================
  Sub RangeCopy(srcSheet As String, srcTopCell As String, _
  destSheet As String, destTopCell As String)
  Sheets(srcSheet).Range(srcTopCell).Select
  If Not SelectTo(eDownMost) Then
  Sheets(destSheet).Range(destTopCell).Select
  Else
  Selection.Copy Sheets(destSheet).Range(destTopCell)
  End If
  End Sub
  Sub RangeSum(Optional HeaderAtLeft As String = "Total", Optional colorIndex As Integer = 4)
  Go.DownMost
  Go.Down
  If ActiveCell.Row = 2 Then
  ActiveCell.FormulaR1C1 = ""
  Else
  Dim Temp As Integer
  Temp = ActiveCell.Row - 2
  ActiveCell.FormulaR1C1 = "=SUM(R[-" + CStr(Temp) + "]C:R[-1]C)"
  End If
  
  If HeaderAtLeft <> "" Then
  If Go.Left Then
  ActiveCell.FormulaR1C1 = "Total"
  Selection.Font.colorIndex = colorIndex
  End If
  End If
  End Sub
  Sub RangeCopySum(srcSheet As String, srcCol As String, _
  destSheet As String, destCol As String, _
  Optional HeaderAtLeft As String = "Total", Optional colorIndex As Integer = 4)
  RangeCopy srcSheet, srcCol, destSheet, destCol
  RangeSum HeaderAtLeft, colorIndex
  End Sub

  ' =============================Search============================
  ' Take Out vSearchFormat for older Excel.
  Function Find(vWhat As String, Optional vAfter As String = "A1", _
  Optional vLookInFormulas As Boolean = True, _
  Optional vByPart As Boolean = True, Optional vByRows As Boolean = True, _
  Optional vMatchCase As Boolean = False, Optional vSearchFormat As Boolean = False) As Boolean
  Range(vAfter).Select
  Dim vLookInFormulas2, vByPart2, vByRows2
  If vLookInFormulas Then
  vLookInFormulas2 = xlFormulas
  Else
  vLookInFormulas2 = xlValues
  End If
  
  If vByPart Then
  vByPart2 = xlPart
  Else
  vByPart2 = xlWhole
  End If
  
  If vByRows Then
  vByRows2 = xlByRows
  Else
  vByRows2 = xlByColumns
  End If
  
  On Error GoTo FindByRow_Error_Handle
  Cells.Find(What:=vWhat, After:=ActiveCell, LookIn:=vLookInFormulas2, _
  LookAt:=vByPart2, SearchOrder:=vByRows2, SearchDirection:=xlNext, _
  MatchCase:=vMatchCase).Activate
  'MatchCase:=vMatchCase, SearchFormat:=vSearchFormat).Activate
  
  Find = True
  Exit Function
  FindByRow_Error_Handle:
  Find = False
  End Function

  ' =============================Other============================
  Sub FreshSheet(name As String)
  Dim oldAlerts
  oldAlerts = Application.DisplayAlerts
  
  On Error Resume Next
  Sheets(1).Select
  Application.DisplayAlerts = False
  Sheets(name).Delete
  Sheets.Add
  ActiveSheet.name = name
  Range("A1").Select
  Application.DisplayAlerts = oldAlerts
  On Error GoTo 0
  End Sub

  Sub DisableFilter(identifier As Variant)
  Sheets(identifier).Range("A1").Select
  Application.CutCopyMode = False
  ActiveSheet.AutoFilterMode = False
  End Sub

  Sub EnableFilter(identifier As Variant)
  DisableFilter identifier
  Selection.AutoFilter
  End Sub

  Sub MoveAndText(Direction As emMove, text As String)
  Go.Move Direction
  ActiveCell.FormulaR1C1 = text
  End Sub
  Sub TextAndMove(Direction As emMove, text As String)
  ActiveCell.FormulaR1C1 = text
  Go.Move Direction
  End Sub

  ' Works With Excel (xls), Tab Delimited (txt), and Comma Demilited (csv).
  ' Haven't try it with other files, but no need also.
  Sub GetDataFromFile(SourceFolder As String, SourceFile As String, DestSheetName As String)
  Dim thisBook As String
  thisBook = ActiveWorkbook.name
  
  FreshSheet DestSheetName
  Workbooks.Open fileName:=SourceFolder + "\" + SourceFile
  Workbooks(SourceFile).ActiveSheet.Cells.Copy Workbooks(thisBook).Sheets(DestSheetName).Range("A1")
  Workbooks(SourceFile).Close False
  Workbooks(thisBook).Sheets(DestSheetName).Select
  End Sub

  ' The current active window Will be closed
  Sub GetDataActiveWindow(DestSheetName As String)
  Dim thisBook As String, thisSheet As String
  thisBook = ActiveWorkbook.name
  thisSheet = ActiveSheet.name
  
  Windows(ThisWorkbook.name).Activate
  FreshSheet DestSheetName
  Workbooks(thisBook).Sheets(thisSheet).Cells.Copy Workbooks(ThisWorkbook.name).Sheets(DestSheetName).Range("A1")
  Workbooks(thisBook).Close False
  Workbooks(ThisWorkbook.name).Sheets(DestSheetName).Select
  End Sub

  ' Take out un-visible items
  Function SheetTrim(Optional SheetName As String, Optional overwriteOriginal As Boolean = False) As String
  If SheetName = "" Then SheetName = ActiveSheet.name
  Dim oldAlerts, extraPhrase
  oldAlerts = Application.DisplayAlerts
  extraPhrase = "_afterTrim"
  
  FreshSheet SheetName + extraPhrase
  Sheets(SheetName).Range("A1").CurrentRegion.Copy Sheets(SheetName + extraPhrase).Range("A1")
  
  If overwriteOriginal Then
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets(SheetName).Delete
  Application.DisplayAlerts = oldAlerts
  On Error GoTo 0
  Sheets(SheetName + extraPhrase).Select
  ActiveSheet.name = SheetName
  SheetTrim = SheetName
  Else
  SheetTrim = SheetName + extraPhrase
  End If
  End Function

  ' Close the workbook without saving. Close Application if no more workbooks in the application.
  ' Use ActiveWorkbook if no book name supplied.
  Sub CloseWorkBook(Optional book As String)
  If book = "" Then book = ActiveWorkbook.name
  On Error GoTo Failed
  Workbooks(book).Saved = True
  On Error GoTo 0
  
  If Application.Workbooks.Count < 2 Then
  Application.Quit
  Else
  Workbooks(book).Close
  End If
  Exit Sub
  Failed:
  End Sub

  'Motive: Sometimes it is eaiser to debug when you use ActiveCell as current data record or parameter.
  ' When the macro stopped by exception or stop sign, you can determine the running progress by ActiveCell.
  ' And it is easier to say Up(5) instead of offset the row index, for me at least.

  'Summary: The Utility_Move class introduce 3 sets of functions.
  'First set, Up-Down-Right-Left simulate the key stroke of arrow keys.
  ' Additionally, Steps parameter allows you to repeat number of seps to that direction.
  ' Negative steps also means that you are stepping backward.
  ' The SkipHidden parameter skips hidden cells. When true, it acts like arrow keys that
  ' skips hidden rows by filter. When false, it will not skip hidden rows and select hidden cells.
  'Second set, UpEnd-DownEnd-RightEnd-LeftEnd simulate arrow keys pressed after the End key.
  ' It offers same parameters as the first set, and behave the same.
  'Third set, UpMost-DownMost-RightMost-LeftMost will locate the
  ' very last non-empty cell in that direction. Spaces are treated as non-empty cell.
  ' Features SkipHidden feature, when true, only select the visible last cell.

  'Option Explicit
  Public Enum emMove
  eUp = -1
  eDown = 1
  eLeft = -2
  eRight = 2
  
  eUpEnd = -4
  eDownEnd = 4
  eLeftEnd = -8
  eRightEnd = 8
  
  eUpMost = -16
  eDownMost = 16
  eLeftMost = -32
  eRightMost = 32
  End Enum

  ' =============================Move Cell============================
  Function Move(Direction As emMove, Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Select Case Direction
  Case emMove.eUp
  Move = Up(Steps, SkipHidden)
  Case emMove.eDown
  Move = Down(Steps, SkipHidden)
  Case emMove.eRight
  Move = Right(Steps, SkipHidden)
  Case emMove.eLeft
  Move = Left(Steps, SkipHidden)
  Case emMove.eUpEnd
  Move = UpEnd(Steps, SkipHidden)
  Case emMove.eDownEnd
  Move = DownEnd(Steps, SkipHidden)
  Case emMove.eRightEnd
  Move = RightEnd(Steps, SkipHidden)
  Case emMove.eLeftEnd
  Move = LeftEnd(Steps, SkipHidden)
  Case emMove.eUpMost
  Move = UpMost(SkipHidden)
  Case emMove.eDownMost
  Move = DownMost(SkipHidden)
  Case emMove.eRightMost
  Move = RightMost(SkipHidden)
  Case emMove.eLeftMost
  Move = LeftMost(SkipHidden)
  End Select
  End Function

  '=============================================================================
  ' Move To Direction
  Private Function OneStep(Direction As emMove, Optional SkipHidden As Boolean = False) As Boolean
  OneStep = False
  On Error GoTo Error
  Do
  Select Case Direction
  Case emMove.eUp
  ActiveCell.Offset(-1, 0).Range("A1").Select
  Case emMove.eDown
  ActiveCell.Offset(1, 0).Range("A1").Select
  Case Else
  Exit Do
  End Select
  Loop Until SkipHidden = False Or ActiveCell.EntireRow.Hidden = False
  
  Do
  Select Case Direction
  Case emMove.eRight
  ActiveCell.Offset(0, 1).Range("A1").Select
  Case emMove.eLeft
  ActiveCell.Offset(0, -1).Range("A1").Select
  Case Else
  Exit Do
  End Select
  Loop Until SkipHidden = False Or ActiveCell.EntireColumn.Hidden = False
  
  OneStep = True
  Exit Function
  Error:
  OneStep = False
  End Function

  Private Function MoreSteps(Direction As emMove, Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  If Steps < 0 Then Direction = Direction * -1: Steps = Steps * -1
  For i = 1 To Steps
  If OneStep(Direction, SkipHidden) = False Then MoreSteps = False: Exit Function
  Next
  MoreSteps = True
  End Function

  Function Up(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Up = MoreSteps(eUp, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function Down(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Down = MoreSteps(eDown, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function Left(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Left = MoreSteps(eLeft, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function Right(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  Right = MoreSteps(eRight, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function

  '=============================================================================
  ' Move To Direction End
  Private Function OneStepEnd(Direction As emMove, Optional SkipHidden As Boolean = False) As Boolean
  OneStepEnd = True
  Do
  Select Case Direction
  Case emMove.eUpEnd
  If ActiveCell.Row = 1 Then OneStepEnd = False: Exit Function
  Selection.End(xlUp).Select
  Case emMove.eDownEnd
  If ActiveCell.Row = Rows.Count Then OneStepEnd = False: Exit Function
  Selection.End(xlDown).Select
  Case Else
  Exit Do
  End Select
  Loop Until SkipHidden = False Or ActiveCell.EntireRow.Hidden = False
  
  Do
  Select Case Direction
  Case emMove.eLeftEnd
  If ActiveCell.Column = 1 Then OneStepEnd = False: Exit Function
  Selection.End(xlToLeft).Select
  Case emMove.eRightEnd
  If ActiveCell.Column = Columns.Count Then OneStepEnd = False: Exit Function
  Selection.End(xlToRight).Select
  Case Else
  Exit Do
  End Select
  Loop Until SkipHidden = False Or ActiveCell.EntireColumn.Hidden = False
  End Function

  Private Function MoreStepsEnd(Direction As emMove, Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  If Steps < 0 Then Direction = Direction * -1: Steps = Steps * -1
  For i = 1 To Steps
  If OneStep(Direction, SkipHidden) = False Then MoreStepsEnd = False: Exit Function
  Next
  MoreStepsEnd = True
  End Function

  Function UpEnd(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  UpEnd = MoreStepsEnd(eUpEnd, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function DownEnd(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  DownEnd = MoreStepsEnd(eDownEnd, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function LeftEnd(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  LeftEnd = MoreStepsEnd(eLeftEnd, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function
  Function RightEnd(Optional Steps As Long = 1, Optional SkipHidden As Boolean = False) As Boolean
  RightEnd = MoreStepsEnd(eRightEnd, Steps:=Steps, SkipHidden:=SkipHidden)
  End Function

  '=============================================================================
  ' Move To Direction Most
  Private Function OneStepMost(Direction As emMove, Optional SkipHidden As Boolean = False) As Boolean
  OneStepMost = False
  Select Case Direction
  Case emMove.eUpMost
  Cells(1, ActiveCell.Column).Select
  Case emMove.eDownMost
  Cells(Rows.Count, ActiveCell.Column).Select
  Case emMove.eLeftMost
  Cells(ActiveCell.Row, 1).Select
  Case emMove.eRightMost
  Cells(ActiveCell.Row, Columns.Count).Select
  Case Else
  Exit Function
  End Select
  
  If ActiveCell.FormulaR1C1 = "" Then OneStepEnd Direction, SkipHidden:=SkipHidden
  If ActiveCell.FormulaR1C1 = "" Then
  If Direction = eUpMost Then Cells(1, ActiveCell.Column).Select
  If Direction = eLeftMost Then Cells(ActiveCell.Row, 1).Select
  OneStepMost = False
  Else
  OneStepMost = True
  End If
  End Function

  Function UpMost(Optional SkipHidden As Boolean = False) As Boolean
  UpMost = OneStepMost(eUpMost, SkipHidden:=SkipHidden)
  End Function
  Function DownMost(Optional SkipHidden As Boolean = False) As Boolean
  DownMost = OneStepMost(eDownMost, SkipHidden:=SkipHidden)
  End Function
  Function LeftMost(Optional SkipHidden As Boolean = False) As Boolean
  LeftMost = OneStepMost(eLeftMost, SkipHidden:=SkipHidden)
  End Function
  Function RightMost(Optional SkipHidden As Boolean = False) As Boolean
  RightMost = OneStepMost(eRightMost, SkipHidden:=SkipHidden)
  End Function
  

  
  

• kjkramer

  Hi Jonas,

  Yes there is a rather smart way of doing this using the input box here's an example.

  'selects the cell and returns the value of that cell
  Dim myRange As Range
  Set myRange = Application.InputBox(prompt:="Select the cell containing the data you want.", Type:=8)
  If Not myRange Is Nothing Then
  'cancel pressed
  End If

  
  
  

• Lita123

  Thanks again Derek! It works just perfect.
  
  
• Allowing the user to pick a cell in excel