S
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.
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.