VBA to cut last few characters and paste in next column

[BillDoor]

Hi all

I have a dataset that is a list of items that can be several words long, then at the end is a code in brackets (***)
The code can also vary in length between 1 and 3 characters (there are 5 different codes)

What I need to do is loop through the column with this data in and cut the code from the end and move that to the next cell over eg A2 to B2
I don't want the code remaining in the original cell
I have tried doing this as below, but am having to repeat it for each code and change the number of characters it looks at each time.
I'm sure there's a more efficient way of doing this, any ideas please?

Sub test2()

    LastRow = Range("A1048576").End(xlUp).Row
    
    Range("A2").Select
    Do Until ActiveCell.Row = LastRow + 1
        If Right(ActiveCell, 3) = "(x)" Then
            ActiveCell.Offset(0, 2) = "(x)"
            ActiveCell.Offset(1, 0).Select
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
end sub

[karedog]

Hi,

Maybe :

Sub Test()
  Dim arr, i As Long, j As Long
  arr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Resize(, 2).Value
  For i = 1 To UBound(arr, 1)
      If Len(arr(i, 1)) Then
         j = 0: j = InStrRev(arr(i, 1), "(")
         If j Then
            arr(i, 2) = Mid(arr(i, 1), j)
            arr(i, 1) = Left(arr(i, 1), (j - 1))
         End If
      End If
  Next i
  Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

[JOHN H. DAVIS]

Maybe:

Sub BillDoor()
Dim i As Long, x As Long, y As Long
For i = 2 To Range("A" & Rows.Count).End(3).row
x = Len(Cells(i, "A"))
        With Cells(i, "B")
            .Formula = "=FIND(""(""," & Cells(i, "A").Address & ")"
            If IsError(Cells(i, "B")) Then
            .Value = ""
            Cells(i, "A").Value = Cells(i, "A").Value
            Else
            .Value = .Value
            y = Cells(i, "B").Value - 1
            .Value = Right(Cells(i, "A"), x - y)
            Cells(i, "A") = Left(Cells(i, "A"), y)
            End If
        End With
Next i
End Sub

[BillDoor]

Hi both

both of these work - to a point
if the code between the brackets is just a number then it's displaying the number as a negative without the brackets - (15) becomes -15
Also, I need it to move two columns over, not just 1, John - I can see how to amend yours to do this, but am not sure with karedog's

thanks both

[karedog]

This will put the second result in column C :

Sub Test()
  Dim arr1, arr2(), i As Long, j As Long
  arr1 = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
  ReDim arr2(1 To UBound(arr1, 1), 1 To 1)
  For i = 1 To UBound(arr1, 1)
      If Len(arr1(i, 1)) Then
         j = 0: j = InStrRev(arr1(i, 1), "(")
         If j Then
            arr2(i, 1) = "'" & Mid(arr1(i, 1), j)
            arr1(i, 1) = Left(arr1(i, 1), (j - 1))
         End If
      End If
  Next i
  Range("A2").Resize(UBound(arr1, 1)).Value = arr1
  Range("C2").Resize(UBound(arr2, 1)).Value = arr2
End Sub

[JOHN H. DAVIS]

Modified:

Sub BillDoor()
Dim i As Long, x As Long, y As Long
For i = 2 To Range("A" & Rows.Count).End(3).row
x = Len(Cells(i, "A"))
        With Cells(i, "B").Offset(, 1)
            .Formula = "=FIND(""(""," & Cells(i, "A").Address & ")"
            If IsError(Cells(i, "B").Offset(, 1)) Then
            .Value = ""
            Cells(i, "A").Value = Cells(i, "A").Value
            Else
            .Value = .Value
            y = Cells(i, "B").Offset(, 1).Value - 1
            .Value = "'" & Right(Cells(i, "A"), x - y)
            Cells(i, "A") = Left(Cells(i, "A"), y)
            End If
        End With
Next i
End Sub

[BillDoor]

spot on, thanks both!!

[karedog]

You are welcome, thanks for the rep. points.


Regards

[JOHN H. DAVIS]

You're welcome. Glad to help out and thanks for the feedback.