CODEWITHSUNDEEP
vbaexcel
Aman Devrath
Aman Devrath

Reputation: 406

select adjacent cell in entire column VBA

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.

Upvotes: 0

Views: 1240

Answers (1)

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9976

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

Upvotes: 1

Related Questions