Macro To Delete Numbers With Trailing Character

I have numbers appearing in Col B on sheet Imported data. I would like a macro to delete the numbers with a trailing X for Eg 13030X, 13040X, 13050X, 13060X etc where the value in Col D is zero

Your assistance in this regard is most appreciated

Try this:

Code:

---

Option Explicit

Sub Lalit_Test()

    Dim varData()                      As Variant
    Dim varFinalData()                  As Variant
    Dim rngNumberRange                  As Range
    Dim lngLoop                        As Long
    Dim lngCount                        As Long
   
    Const strTrailingChar              As String = "X" 'change this accordingly
    Const strSrcCell                    As String = "B1" 'change this accordingly
    Const strDstCell                    As String = "G2" 'change this accordingly
    Const strSheetName                  As String = "Sheet1" 'change this accordingly
   
    With ThisWorkbook.Worksheets(strSheetName)
        Set rngNumberRange = .Range(strSrcCell)
        Set rngNumberRange = rngNumberRange.Resize(.Cells(.Rows.Count, rngNumberRange.Column).End(xlUp).Row)
        If rngNumberRange.Rows.Count > 1 Then
            Set rngNumberRange = Intersect(rngNumberRange, rngNumberRange.Offset(1))
            varData = rngNumberRange.Resize(, 3)
            ReDim varFinalData(1 To UBound(varData), 1 To UBound(varData, 2))
            lngCount = 0
            For lngLoop = LBound(varData) To UBound(varData)
                If Right(LCase(varData(lngLoop, 1)), Len(strTrailingChar)) = LCase(strTrailingChar) Then
                    If varData(lngLoop, 3) <> 0 Then
                        lngCount = lngCount + 1
                        varFinalData(lngCount, 1) = varData(lngLoop, 1)
                        varFinalData(lngCount, 2) = varData(lngLoop, 2)
                        varFinalData(lngCount, 3) = varData(lngLoop, 3)
                    End If
                Else
                    lngCount = lngCount + 1
                    varFinalData(lngCount, 1) = varData(lngLoop, 1)
                    varFinalData(lngCount, 2) = varData(lngLoop, 2)
                    varFinalData(lngCount, 3) = varData(lngLoop, 3)
                End If
            Next lngLoop
            Set rngNumberRange = .Range(strDstCell)
            rngNumberRange.Resize(, UBound(varFinalData, 2)).EntireColumn.ClearContents
            Set rngNumberRange = rngNumberRange.Resize(UBound(varFinalData), UBound(varFinalData, 2))
            rngNumberRange.Value = varFinalData
            rngNumberRange.EntireColumn.AutoFit
        End If
    End With
   
    Erase varData
    Erase varFinalData
    Set rngNumberRange = Nothing
    lngLoop = Empty
    lngCount = Empty

End Sub

---

:cheers:

Thanks for the reply and your help

The rows containing a trailing X in Col B and where the value in Col D based in the account number ending in an X is not being deleted.

I have attached a sample file with very little data to show you what I want to achieve , indicating which rows to be deleted i.e trailing X + where the value containing the trailing X is zero.

Kindly amend your code accordingly

Hi

another option..

Code:

---

Option Explicit

Sub kTest()
       
    Dim b  As String, d As String
   
    Const TrailingChar = "x"    'adjust the char
    Const SpeclChar = "####"
   
    With Intersect(ActiveSheet.UsedRange, Range("a:d"))
        b = .Columns(2).Address
        d = .Columns(4).Address
        On Error Resume Next
        .Columns(2).SpecialCells(4) = SpeclChar
        .Columns(2) = Evaluate("if(" & d & "<>0,if(right(" & b & ",len(""" & TrailingChar & """))=""" & TrailingChar & """,left(" & b & ",len(" & b & ")-len(""" & TrailingChar & """))," & b & ")," & b & ")")
        .Columns(2).Replace SpeclChar, vbNullString, 1
    End With
   
End Sub

---

Thanks for the help. The rows containing the numbers with the trailing X in Col B where the value in Col D is zero has not been deleted when activating the macro

Your asistance in resolving this will be most appreciated

I have attached the sample data

Hi

I assume your sheet has data in Col A through Col D (at least one cell in each col) , otherwise my code won't work.

Code:

---

Sub kTest()
       
    Dim b  As String, d As String
   
    Const TrailingChar = "x"    'adjust the char
    Const BlankChar = "####"
    Const DeleChar = "||||"
   
    Application.ScreenUpdating = False
   
    With Intersect(ActiveSheet.UsedRange, Range("a:d"))
        b = .Columns(2).Address
        d = .Columns(4).Address
        On Error Resume Next
        .Columns(2).SpecialCells(4) = BlankChar
        .Columns(2) = Evaluate("if(" & d & "=0,if(right(" & b & ",len(""" & TrailingChar & """))=""" & TrailingChar & """,""" & DeleChar & """," & b & ")," & b & ")")
        .Columns(2).Replace DeleChar, vbNullString, 1
        .Columns(2).SpecialCells(4).EntireRow.Delete
        .Columns(2).Replace BlankChar, vbNullString, 1
    End With
   
    Application.ScreenUpdating = True
   
End Sub

---

Thanks for the help, much appreciated

When runnning the macro, I leaves a blank in one of the cells in Col B which had a trailing X-see example attached which contains yiour macro

It would be appreciated if you would correct this

Hi

add this line

Code:

---

.ClearFormats

---

after line

Code:

---

On Error Resume Next

---

Note: Clear Formats under Home > Clear will remove the trailing apostrophe

thanks for the help, much appreciated