VBA: Selecting cells of certain value AND also selecting the adjacent cells

[onetimesten]

Hey,

I have two simple columns of data: one with names (Column A) and the other with numbers (Column B).
I am looking for the most efficient way of selecting cells in Column B of a certain value and also selecting the cells to the left of those selected cells in Column A.

I have the current code based on SpecialCells, it works most of the time but for some reason it's buggy and sometimes returns an error. Is there another way doing this without using Special Cells?

Thanks a million!

Sub SelectbyValue()
Dim Cell As Object
Dim FoundCells As Range 'Range that's found
Dim WorkRange As Range 'Range to search
Range("E1:F4").ClearContents
Range("A1").Select
If TypeName(Selection) <> "Range" Then Exit Sub
' Check all or selection?
If Selection.CountLarge = 1 Then
Set WorkRange = ActiveSheet.UsedRange
Else
Set WorkRange = Application.Intersect(Selection, ActiveSheet.UsedRange)
End If
' Reduce the search to numeric cells only
On Error Resume Next
Set WorkRange = WorkRange.SpecialCells(xlConstants, xlNumbers)
If WorkRange Is Nothing Then Exit Sub
On Error GoTo 0
' Loop through each cell, add to the FoundCells range if it qualifies
For Each Cell In WorkRange
If Cell.Value > 1000 Or Cell.Value < -1000 Then
If FoundCells Is Nothing Then
Set FoundCells = Cell
Else
Set FoundCells = Union(FoundCells, Cell)
End If
End If
Next Cell
' Show Message, or select the cells
If FoundCells Is Nothing Then
MsgBox "No cells qualify."
Else
FoundCells.Copy
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues
' FoundCells.Copy Range("F1")
' Selection.Copy Range("F1")
FoundCells.Offset(0, -1).Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End If
Range("E1").CurrentRegion.Select
End Sub

 

[Mohammad Basem]

Welcome to the forum!

If you have two columns A and B with already defined type of data—text and number—you may try replacing

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Range("E1:F4").ClearContents
Range("A1").Select
If TypeName(Selection) <> "Range" Then Exit Sub
' Check all or selection?
If Selection.CountLarge = 1 Then
Set WorkRange = ActiveSheet.UsedRange
Else
Set WorkRange = Application.Intersect(Selection, ActiveSheet.UsedRange)
End If
' Reduce the search to numeric cells only
On Error Resume Next
Set WorkRange = WorkRange.SpecialCells(xlConstants, xlNumbers)
If WorkRange Is Nothing Then Exit Sub
On Error GoTo 0[/COLOR][/SIZE][/FONT]

with

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Range("E1").CurrentRegion.ClearContents
Set WorkRange = Range("A1").CurrentRegion.SpecialCells(xlConstants, xlNumbers)[/COLOR][/SIZE][/FONT]

 

[onetimesten]

Thanks Mohammad! That seems to shorten the code a lot and works great. Awesome!

 

[Mohammad Basem]

Al-hamdullah, you are most welcome and thank you for the feedback!