Move cells according to value

[saman110 via OfficeKB.com]

Hello All,

I have this macro, what is does is it keeps in the column directionals like S,
W, N, E and moves the rest to the next column. What is want is opposite keep
everything and move the directional to the next column. Any help?

Sub Move_Value()
Dim rngB As Range
Dim cel As Range
Dim strToFind As String
Dim strValid As String

'String to have both leading and trailing commas for each value
strValid = ",N,S,W,E,NE,NW,SW,SE,WN,WS,ES,EN,"

'NOTE:Cells(2, "B") starts row 2.
'To start row 1 change to Cells(1, "B")
With Sheets("Sheet1") 'Edit sheet name if required
Set rngB = Range(Cells(2, "B"), _
Cells(Rows.Count, "B").End(xlUp))
rngB.Select
End With

For Each cel In rngB
'Create string from cell value with
'leading and trailing commas
strToFind = "," & cel.Value & ","

'Test for existance of string
'If following line returns Zero then not found.
If InStr(1, strValid, strToFind) = 0 Then
'Not found therefore copy to column C
cel.Offset(0, 1) = cel.Value
'Clear value from column B
cel.ClearContents
End If
Next cel

End Sub



Thx.

 

[saman110 via OfficeKB.com]

Can anybody help? please

Hello All,

I have this macro, what is does is it keeps in the column directionals like S,
W, N, E and moves the rest to the next column. What is want is opposite keep
everything and move the directional to the next column. Any help?

Sub Move_Value()
Dim rngB As Range
Dim cel As Range
Dim strToFind As String
Dim strValid As String

'String to have both leading and trailing commas for each value
strValid = ",N,S,W,E,NE,NW,SW,SE,WN,WS,ES,EN,"

'NOTE:Cells(2, "B") starts row 2.
'To start row 1 change to Cells(1, "B")
With Sheets("Sheet1") 'Edit sheet name if required
Set rngB = Range(Cells(2, "B"), _
Cells(Rows.Count, "B").End(xlUp))
rngB.Select
End With

For Each cel In rngB
'Create string from cell value with
'leading and trailing commas
strToFind = "," & cel.Value & ","

'Test for existance of string
'If following line returns Zero then not found.
If InStr(1, strValid, strToFind) = 0 Then
'Not found therefore copy to column C
cel.Offset(0, 1) = cel.Value
'Clear value from column B
cel.ClearContents
End If
Next cel

End Sub

Thx.

 

[Dave Peterson]

I like to use application.match to see if there's a match.

And watch out for your unqalified ranges:

 

[Dave Peterson]

Oops.

I like to use application.match to see if there's a match.

And watch out for your unqalified ranges. In this statement, range(), cells()
and cells() may not refer to Sheet1. They'll either refer to the activesheet
(if the code is in a general module) or refer to the worksheet owning the code
(if the code is behind a worksheet).

Set rngB = Range(Cells(2, "B"), _
Cells(Rows.Count, "B").End(xlUp))

Anyway...


Option Explicit
Sub Move_Value2()
Dim rngB As Range
Dim cel As Range
Dim strToFind As String
Dim ValidArray As Variant
Dim res As Variant

'String to have both leading and trailing commas for each value
ValidArray = Array("N", "S", "W", "E", "NE", "NW", "SW", _
"SE", "WN", "WS", "ES", "EN")


With Sheets("Sheet1") 'Edit sheet name if required
'watch your dots here. You had unqualified ranges
Set rngB = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
End With

For Each cel In rngB.Cells
res = Application.Match(cel.Value, ValidArray, 0)

If IsNumeric(res) Then
'it was found, so move it
cel.Offset(0, 1).Value = cel.Value
cel.ClearContents
End If
Next cel

End Sub