I am trying to truncate cells in a column from a specific character in a string

[goldbeje]

I have a macro coded to create a new sheet, copy from the first sheet, and paste in specific format to the newly created sheet2. My problem is I cannot get column C to truncate at the end of each cell's string; being "..D" or "...D*". Every cell in column C ends in either "D" or "D*" and I need this removed. Any assistance would be helpful.

Code I am currently working with is shown below. I would like to insert the needed code after

CopyPaste_Sheet2.Hide
ActiveWorkbook.Sheets(2).Activate

Option Explicit

Private Sub CommandButton1_Click()

Sheets.Add.Name = "Sheet2"
ActiveSheet.Move _
       After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
       'Moves active sheet to end of active workbook.
       
      ActiveWorkbook.Sheets(1).Activate

    Dim r As Range
    Dim srcID As String
    Dim lr, sR, i, c, INDX As Long
    Set r = ActiveSheet.Range("B1:B99").Find(What:="PCR Plate ID", LookAt:=xlPart)
    INDX = 1
    i = 2
    lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    Range("B" & r.Row & ",C" & r.Row & ",G" & r.Row).Copy Destination:=Sheets(2).Range("B1")
    For c = (r.Row + 1) To lr Step 3
        srcID = Range("B" & c).Text
         
        With Sheets(2)
            .Range("A" & i & ":A" & i + 3).Value = INDX
            .Range("B" & i & ":B" & i + 3).Value = srcID
        End With
         
        Range("C" & c & ",G" & c).Copy Destination:=Sheets(2).Range("C" & i)
        Range("H" & c & ",L" & c).Copy Destination:=Sheets(2).Range("C" & i + 1)
        Range("C" & c + 1 & ",G" & c + 1).Copy Destination:=Sheets(2).Range("C" & i + 2)
        Range("H" & c + 1 & ",L" & c + 1).Copy Destination:=Sheets(2).Range("C" & i + 3)
         
        i = i + 4
        INDX = INDX + 1
    Next c
    
    CopyPaste_Sheet2.Hide
    ActiveWorkbook.Sheets(2).Activate
    
    
    UserForm1.Show vbModeless
    UserForm1.Left = UserForm1.Left - UserForm1.Width / 2
    UserForm2.Show vbModeless
    UserForm2.Left = UserForm2.Left + UserForm1.Width / 2

End Sub

Thanks for looking at my frustrations.

J.

[Leith Ross]

Hello goldbeje,

This version of your macro will remove the "D" and "D *" at the end of the cells on Sheet2.

Private Sub CommandButton1_Click()

Dim Cell As Range
Dim Rng As Range
Dim r As Range
Dim srcID As String
Dim lr, sR, i, c, INDX As Long

    Sheets.Add.Name = "Sheet2"
    ActiveSheet.Move _
        After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
       'Moves active sheet to end of active workbook.
       
        ActiveWorkbook.Sheets(1).Activate

    Set r = ActiveSheet.Range("B1:B99").Find(What:="PCR Plate ID", LookAt:=xlPart)
    INDX = 1
    i = 2
    lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    Range("B" & r.Row & ",C" & r.Row & ",G" & r.Row).Copy Destination:=Sheets(2).Range("B1")
    For c = (r.Row + 1) To lr Step 3
        srcID = Range("B" & c).Text
         
        With Sheets(2)
            .Range("A" & i & ":A" & i + 3).Value = INDX
            .Range("B" & i & ":B" & i + 3).Value = srcID
        End With
         
        Range("C" & c & ",G" & c).Copy Destination:=Sheets(2).Range("C" & i)
        Range("H" & c & ",L" & c).Copy Destination:=Sheets(2).Range("C" & i + 1)
        Range("C" & c + 1 & ",G" & c + 1).Copy Destination:=Sheets(2).Range("C" & i + 2)
        Range("H" & c + 1 & ",L" & c + 1).Copy Destination:=Sheets(2).Range("C" & i + 3)
        
        i = i + 4
        INDX = INDX + 1
    Next c
    
    Set Rng = Sheets(2).Range("C2:C" & i)
    
    With CreateObject("VBScript.RegExp")
        .Pattern = "(.+)(D\s\*|D\s*\b)"
            For Each Cell In Rng
                Cell = .Replace(Cell, "$1")
            Next Cell
    End With
    
    CopyPaste_Sheet2.Hide
    UserForm1.Show vbModeless
    UserForm1.Left = UserForm1.Left - UserForm1.Width / 2
    UserForm2.Show vbModeless
    UserForm2.Left = UserForm2.Left + UserForm1.Width / 2

End Sub

[goldbeje]

Thank you Ross!! That defnitely works. I was racking my brain last night and came up with this...

 With regEx
    .IgnoreCase = True
    .MultiLine = False
    .Pattern = "D.{0,2}$"
    .Global = True
End With
For Each Rng In Range(Sheets("Sheet2").Range("c2"), Sheets("Sheet2").Range("c" & Rows.Count).End(xlUp))
    Rng.Value = regEx.Replace(Rng, "")
Next

Much appreciated!!

J.