Need help creating a macro which removes initials (example : "T.") from column H if column J equals to "Company One".

I've tried the code below, but it has no effect. How can I go about this?

Option Explicit

Public Sub removeInitials()

    With ThisWorkbook.ActiveSheet.UsedRange
        If ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
        .AutoFilter Field:=10, Criteria1:="Company One"
        .Columns(8).Offset(2).Replace What:=" *[A-Z].", Replacement:=""
        .AutoFilter
    End With

End Sub

CodePudding user response：

If you don't have to large a database this should do the trick w/o messing with filters. Note: I changed the column for Employer for my example. I also changed the data a little to show it works thus the inclusion of the starting/ending points.

Public Sub removeInitials()

   Dim wks  As Worksheet
   Dim lRow As Long
   
   Set wks = ActiveSheet
   lRow = 2
    With wks
        Do While (.Cells(lRow, 1) <> "")
         If (.Cells(lRow, 3) = "Company Two" And Right(.Cells(lRow, 1), 1) = ".") Then
           Debug.Print "Current Row " & lRow
           .Cells(lRow, 1) = Left((.Cells(lRow, 1)), Len(.Cells(lRow, 1)) - 3)
         End If
         Debug.Print lRow
         lRow = lRow   1
        Loop
    End With

End Sub 'removeInitials

Starting Point

Ending Point

CodePudding user response：

If you want to avoid VBA, you could just do a formula...put the below in cell K2 (or wherever...) and drag down.

=TRIM(IF(J2="Company One",SUBSTITUTE(H2,IFERROR(MID(H2,FIND(".",H2)-1,2),""),""),H2))

You could also have spill range as shown in column L in screen shot.

=FILTER(TRIM(IF(J2:J9999="Company One",SUBSTITUTE(H2:H9999,IFERROR(MID(H2:H9999,FIND(".",H2:H9999)-1,2),""),""),H2:H9999)),H2:H9999<>"")

If you really want a macro, here's a dynamic one that is pretty straight forward. A perfect answer would do an array, but looping through helps see what's happening.

Sub doReplace()
    Dim changeRange As Range, aCell As Range, aPosition As Long
    Const companySkip = "Company One"
    
    Set changeRange = Intersect(Range("H:H"), ActiveSheet.UsedRange).Offset(1, 0)
    
    For Each aCell In changeRange.Cells
        If aCell.Offset(0, 2).Value = companySkip Then
            aPosition = InStr(1, aCell.Value, ".", vbBinaryCompare)
            
            If aPosition > 0 Then
                aCell.Value = Trim(Replace(aCell.Value, Mid(aCell.Value, aPosition - 1, 2), ""))
                
            End If
            
        End If
    Next aCell

End Sub

CodePudding user response：

I made a few changes, and this worked:

Public Sub removeInitials()

Dim rng As Range
Set rng = ActiveSheet.UsedRange

With rng
    .AutoFilter Field:=3, Criteria1:="Company One"
    .Columns.Item(1).Replace What:=" ?.", Replacement:=""
    .AutoFilter
End With

End Sub

And here is a before execution / after execution snapshot for a comparable example:

What I had to change to get it working:

1. The first parameter you are passing in the replace method wasn't working for me: " *[A-Z]."

Here is a very useful thread regarding pattern syntax, specifically for the replace method if you're interested: How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops

2. I wasn't sure why you used ".Columns(8).Offset(2)" (granted, I can't see the context of your Excel worksheet - but it seemed like you needed to return a range object for the single column with the names only - which you could then run the replace method on. That's what I did using ".Columns.Item(1)"