How to check for 2 different values and delete the text where either of these values are found? - vba

Question

I want to find "Ext" and "/" in a column of data and delete all the text after and including those characters
If it doesn't find those characters in my data then exit the sub
I can do them separately but I definitely over complicated it, there must be an easier way
The data column will also have blanks in so I have to avoid blank cells and check the whole range of data
Code
Sub DeleteAfterText()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="Ext")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "Ext")(0)
'ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
Sub DeleteAfterText2()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="/")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub

Answer 1

This code should work. It is simple to read and easy to understand.
Option Explicit
'The calling Sub
Sub main()
DeleteTextFromColumn ActiveSheet.Range("E1:E3000")
End Sub
Sub DeleteTextFromColumn(ByRef inRange As Range)
Dim cCell As Range
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim strTemp As String
Dim strOut As String
'You can specify which column if more than one column is provided to the
' subroutine. Ex: Range("E1:F3000")
For Each cCell In inRange.Columns(1).Cells
strTemp = cCell.Value
'gets the position of "ext" (case insensitive)
intPos1 = InStr(LCase(strTemp), "ext")
'gets the position of "/"
intPos2 = InStr(strTemp, "/")
strOut = strTemp
If intPos1 > 1 Then
strOut = Mid(strTemp, 1, intPos1 - 1)
ElseIf intPos2 > 1 Then
strOut = Mid(strTemp, 1, intPos2 - 1)
End If
'Outputs the results
cCell.Value = strOut
Next
End Sub

Answer 2

It's best to break out repeated code into a sub which has parameters for the variable parts of the operation.
You can do something like this:
Sub Tester()
Dim theRange As Range
Set theRange = Sheets("User Load").Range("E1:E3000")
RemoveTextAfter theRange, "Ext"
RemoveTextAfter theRange, "/"
End Sub
Sub RemoveTextAfter(rng As Range, findWhat As String)
Dim f As Range
If Len(findWhat) = 0 Then Exit Sub
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Do While Not f Is Nothing
f.Value = Split(f.Value, findWhat)(0)
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Loop
End Sub

Answer 3

I'm going to give you two answers for the price of one. :)
At its root, the basic logic you need to figure out if a substring exists in a given string is a standard part of VBA in the InStr function. Using this, you can break out your logic to check a cell's value and (conditionally) delete the remainder of the string into a function like this:
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
Notice here that using the function created above, we don't need to use Range.Find at all.
Once you have that, your top-level logic consists of setting up the range to search. In all of my code, I explicitly create objects to reference the workbook and worksheet so that I can keep things straight. In a simple example like this, it may seem like overkill, but the habit comes in handy when your code gets more involved. So I set up the range like this
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Now the loop just goes through each cell and gets a (potentially) updated value.
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
So your whole solution looks like this:
Option Explicit
Public Sub TestDirectlyFromRange()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
End Sub
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
But wait, there's more!!
You're iterating over 3,000 rows of data. That can get to be slow if all those rows are filled or if you increase the number of rows to search. To speed up the search, the answer is to copy the data in the range to a memory-based array first, modify any of the data, then copy the results back. This example uses the same Function DeleteTextAfter as above and is much quicker. Use whichever one fits your situation best.
Public Sub TestRangeInArray()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
'--- create the range and copy into a memory array
Dim searchRange As Range
Dim searchData As Variant
Set searchRange = userLoadWS.Range("E1:E3000")
searchData = searchRange.value
Dim i As Long
For i = LBound(searchData, 1) To UBound(searchData, 1)
If Not searchData(i, 1) = vbNullString Then
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "Ext")
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "/")
End If
Next i
'--- now copy the modified array back to the worksheet range
searchRange.value = searchData
End Sub