Hi Paul

I have had a look at your code but it got a little confusing to I
worked from your description in the hope that you will be able to work
the code into your project making the alterations to fit. To test set
up a Userform with two multiselect listboxes called ListBox4 and
ListBox9 and a button below each of the listboxes to launch the code,
they should be named ListBox4Button and ListBox9Button. Then Paste
the following code into the userform module.

It works by first passing the items selected in the list into the next
available cell in either column C or E depending on which List you are
working from. It will also pass the values and list indexes of the
selected items into an array (one for each, I could have put both into
a single array but I find this gets confusing to keep track of) It
will then look for the value in the corresponding column and remove it
and load the value into the opposite ListBox. Lastly it will remove
the selected values from the original ListBox. If you have trouble
let me know and I will comment the code and try to help.

P.S. you will need values in the columns C, D to check against or you
will get an error. I suppose this could be trapped using onerror.
Also in the lines ReDim ValueArr(0 To 100) & ReDim IndexArr(0 To 100)
ensure that you replace 100 with a number greater than you expect the
array to get, i.e. a possible 154 maximum items in a list use 160 or
so.

Option Explicit
Dim i, NewRow, Elm As Integer
Dim Ctrl1, Ctrl2 As Control
Dim Counter As Integer
Dim ValueArr As Variant
Dim IndexArr As Variant
Dim FoundCell As Range

Private Sub ListBox4Button_Click()

NewRow = [E65535].End(xlUp).Row + 1

Set Ctrl1 = ListBox4

Set Ctrl2 = ListBox9

Call MovingStuff

End Sub
Private Sub ListBox9Button_Click()

NewRow = [C65535].End(xlUp).Row + 1

Set Ctrl1 = ListBox9

Set Ctrl2 = ListBox4

Call MovingStuff

End Sub

Sub MovingStuff()

Elm = 0

ReDim ValueArr(0 To 100)
ReDim IndexArr(0 To 100)

For i = 0 To Ctrl1.ListCount - 1

If Ctrl1.Selected(i) = True Then

If Ctrl1.Name = "ListBox4" Then

Cells(NewRow, 5).Value = Ctrl1.List(i)

Else

Cells(NewRow, 3).Value = Ctrl1.List(i)

End If

NewRow = NewRow + 1

ValueArr(Elm) = Ctrl1.List(i)

IndexArr(Elm) = i

Elm = Elm + 1

End If

Next

ReDim Preserve ValueArr(0 To Elm)
ReDim Preserve IndexArr(0 To Elm)

For i = 0 To Elm

If Ctrl1.Name = "ListBox4" Then

Set FoundCell = Worksheets("Sheet5").[C:C].Find _
(What:=ValueArr(i), LookAt:=xlWhole)

Else

Set FoundCell = Worksheets("Sheet5").[E:E].Find _
(What:=ValueArr(i), LookAt:=xlWhole)

End If

FoundCell.Delete Shift:=xlUp

Ctrl2.AddItem (ValueArr(i))

Next

Counter = 0

For i = 0 To UBound(IndexArr) - 1

Ctrl1.RemoveItem (IndexArr(i) - Counter)

Counter = Counter + 1

Next

End Sub

Hope this helps

Steve