select adjacent cell in entire column VBA - vba

Question

Code :
Option Explicit
Sub selectAdjacentBelowCells()
Dim r, c As Integer
Dim r1, r2, c1, c2 As Integer
Dim i As Integer
Dim j As Integer
Dim st As String
Dim lastRow As Integer
With ActiveCell
r = .Row
c = .Column
End With
r1 = r
r2 = r
lastRow = ActiveSheet.Cells(Rows.Count, c).End(xlUp).Row
Dim value As Integer
value = Cells(r, c).value
Dim value1 As Integer
Dim value2 As Integer
Dim myUnion As Range
Dim myCell As Range
For i = r1 To lastRow - 1
'selects adjacent cells below
value1 = Cells(i + 1, c).value
If (value1 = value) Then
Range(Cells(i, c), Cells(i + 1, c)).Select
Else
Exit For
End If
Next
Dim x As Integer
x = Cells(r2 - 1, c).value
For x = r2 To (r2 + 1) - r2 Step -1
'selects adjacent cells above
value2 = Cells(x - 1, c).value
If (value2 = value) Then
Range(Cells(r, c), Cells(x - 1, c)).Select
Else
Exit For
End If
Next
End Sub
Column in excel :
10
20
30
40
50
60
60(this cell is selected and then vba code is executed)
60
70
80
90
I need to select adjacent cells in entire column. It selects adjacent cells, but first it selects adjacent cells below and then above. But the selection changes to above cells and below cells are deselected after the first piece of code runs.
I know it can be done through Union, I tried using it but I got errors everytime. Got argument is not optional error and then I had to remove the Union code and the above code is what I now have.

Answer 1

Please give this a try to see if that works for you.
Sub selectAdjacentBelowCells()
Dim targetCell As Range, Rng As Range, cell As Range, LastCell As Range, uRng As Range
Dim lr As Long
Dim firstAddress As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set targetCell = ActiveCell
Set LastCell = Range("A:A").SpecialCells(xlCellTypeLastCell)
With Range("A1:A" & lr)
Set cell = .Find(what:=targetCell.value, after:=LastCell, LookIn:=xlValues, lookat:=xlWhole)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If uRng Is Nothing Then
Set uRng = cell
Else
Set uRng = Union(uRng, cell)
End If
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End If
End With
For Each Rng In uRng.Areas
If Not Intersect(Rng, targetCell) Is Nothing Then
Rng.Select
Exit For
End If
Next Rng
End Sub