Remove || (pipes) at the end of text inside a column - excel

Question

I have this problem I can't seem to fix...
In column L I have certain roles, these roles are divided by || (pipes).
The problem: Some people deliver these roles they want to use like this:
Testing||Admin||Moderator||
But this doesn't work for the script we use to import these roles, what I would like to see is that whenever || (pipes) are used and after the pipes are used if there isn't any text following it up it should delete the pipes at the end.
What I tried is the find and replace option, but this also removes the pipes in between the text.
Hope someone can help me!
Problem:
Testing||Admin||Moderator||
Solution:
Testing||Admin||Moderator

Answer 1

A simple formula can solve your requirements
=IF(RIGHT(TRIM(A1),2)="||",LEFT(TRIM(A1),LEN(TRIM(A1))-2),A1)
The above formula is based on the below logic.
Check if the right 2 characters are ||
If "Yes", then take the left characters (LEN - 2)
If "No", then return the string as it is.
If you still want VBA then try this code which will make the change in the entire column in one go. Explanation about this method is given HERE.
For demonstration purpose, I am assuming that the data is in column A of Sheet1. Change as applicable.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lrow As Long
Dim rng As Range
Dim sAddr As String
Set ws = Sheet1
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & lrow)
sAddr = rng.Address
rng = Evaluate("index(IF(RIGHT(TRIM(" & sAddr & _
"),2)=""||"",LEFT(TRIM(" & sAddr & _
"),LEN(TRIM(" & sAddr & _
"))-2)," & sAddr & _
"),)")
End With
End Sub
In Action:
I only changed the name of the worksheet and the range to L and L2:L. – Ulquiorra Schiffer 17 mins ago

Answer 2

There are different ways of doing this, but here is one:
Function FixPipes(val As String) As String
Dim v As Variant
v = Split(val, "||")
If Len(v(UBound(v))) > 0 Then
FixPipes = val
Else
FixPipes = Mid$(val, 1, Len(val) - 2)
End If
End Function
Here's another way to do it:
Function FixPipes(val As String) As String
If Mid$(val, Len(val) - 1, 2) <> "||" Then
FixPipes = val
Else
FixPipes = Mid$(val, 1, Len(val) - 2)
End If
End Function
Usage:
Sub test()
Debug.Print FixPipes("Testing||Admin||Moderator||")
End Sub
Or:
Sub LoopIt()
' remove this line after verifying the sheet name
MsgBox ActiveSheet.Name
Dim lIndex As Long
Dim lastRow As Long
lastRow = Range("L" & Rows.Count).End(xlUp).Row
For lIndex = 1 To lastRow
Range("L" & lIndex) = FixPipes(Range("L" & lIndex))
Next
End Sub
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/split-function
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/mid-function

Answer 3

A tiny alternative using negative filtering would be:
Function FixPipes(ByVal s As String, Optional delim As String = "||") As String
Dim tmp: tmp = Filter(Split(s & "$$", delim), "$$", False)
FixPipes = Replace(Join(tmp, delim), "$$", "")
End Function

Answer 4

=IF(UNICODE(RIGHT(A2,1))+UNICODE(LEFT(RIGHT(A2,2),1))=248,LEFT(A2,LEN(A2)-2),A2)

Answer 5

Solution using the Replace formula, if you want to do this in VBA you can use the replace function in VBA as well

Answer 6

Remove Trailing String
All Except OP
This is a follow-up question on How to create data validation based on multiple roles?
.
The answers from Siddharth Rout and braX are valid for someone who might stumble upon this post.
They would have to be adjusted for OP because this case is 'clouded' by an already existing Worksheet_Change event.
OP (Ulquiorra)
To not complicate I have integrated a code snippet, which uses a function (similar to the posted solutions), into your existing code and removed Areas since it seems redundant after seeing what you are trying to accomplish.
The Snippet
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim cel As Range
For Each cel In rng.Cells
cel.Value = removeTrail(cel.Value, Delimiter)
Next cel
Application.EnableEvents = True
The Function
Function removeTrail( _
ByVal SearchString As String, _
ByVal RemoveString As String, _
Optional ByVal doTrim As Boolean = True) _
As String
If doTrim Then
removeTrail = Trim(SearchString)
Else
removeTrail = SearchString
End If
If Right(removeTrail, Len(RemoveString)) = RemoveString Then
removeTrail = Left(removeTrail, Len(removeTrail) - Len(RemoveString))
End If
End Function
The Worksheet Change (modified)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Admin,Clerk,Moderator,User"
Const FirstCellAddress As String = "L2"
Const Delimiter As String = "||"
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
' The Snippet
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim cel As Range
For Each cel In rng.Cells
cel.Value = removeTrail(cel.Value, Delimiter)
Next cel
Application.EnableEvents = True
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each cel In rng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
' Remove this block if you don't need case-sensitivity.
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
End Sub

Answer 7

This is the piece of code I have in the worksheet change event (also module1) and also in the same active worksheet as module2:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Testing"
Const FirstCellAddress As String = "L2"
Const Delimiter As String = "||"
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim cel As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
Next aRng
Application.ScreenUpdating = False
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
End Sub
I did put your code inside a module2 and also in an active worksheet:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lrow As Long
Dim rng As Range
Dim sAddr As String
Set ws = Sheet1
With ws
lrow = .Range("L" & .Rows.Count).End(xlUp).Row
Set rng = .Range("L2:L" & lrow)
sAddr = rng.Address
rng = Evaluate("index(IF(RIGHT(TRIM(" & sAddr & _
"),2)=""||"",LEFT(TRIM(" & sAddr & _
"),LEN(TRIM(" & sAddr & _
"))-2)," & sAddr & _
"),)")
End With
End Sub
For some reason, module2 won't work I suspect module1 to interfere with it indeed but can't find a solution.
My whole code looks like this:
Sub AllInOne()
Application.EnableEvents = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("F2:F" & Cells(rows.Count, "F").End(xlUp).Row).Copy Destination:=Range("J2")
Range("F2:F" & Cells(rows.Count, "F").End(xlUp).Row).Copy Destination:=Range("K2")
ActiveSheet.Hyperlinks.Delete
For Each rng In Range("F2:F" & Cells(rows.Count, "F").End(xlUp).Row): rng.Value = LCase(rng.Value): Next rng
For Each rng In Range("K2:K" & Cells(rows.Count, "K").End(xlUp).Row): rng.Value = LCase(rng.Value): Next rng
For Each rng In Range("J2:J" & Cells(rows.Count, "J").End(xlUp).Row): rng.Value = LCase(rng.Value): Next rng
Dim cell As Range
lastRow = ActiveSheet.Cells(ActiveSheet.rows.Count, "C").End(xlUp).Row
For Each cell In ActiveSheet.Range("C2:C" & lastRow)
S = vbNullString
If cell.Value <> vbNullString Then
v = Split(cell.Value, " ")
For Each W In v
S = S & Left$(W, 1) & "."
Next W
cell.Offset(ColumnOffset:=-1).Value = S
End If
Next cell
Application.Range("B1").Value = "tesing"
Worksheets("Sheet1").Range("B1").Font.Bold = True
Columns("D").Replace What:="vander", _
Replacement:="van der", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("D").Replace What:="vanden", _
Replacement:="van den", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("B").Replace What:="..", _
Replacement:=".", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Dim r As Range
For Each r In ActiveSheet.UsedRange
If Not IsError(r.Value) Then
v = r.Value
If v <> vbNullString Then
If Not r.HasFormula Then
r.Value = Trim(v)
End If
End If
End If
Next r
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
Worksheets("Sheet1").Columns("L").Replace _
What:=" ", _
Replacement:="", _
SearchOrder:=xlByColumns, _
MatchCase:=True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Testing"
Const FirstCellAddress As String = "L2"
Const Delimiter As String = "||"
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim cel As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
Next aRng
Application.ScreenUpdating = False
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
End Sub