Private Sub cmd_Move_Click() '''New code

    Dim i As Long
    Dim f As Long
    Dim rng As Range
    Dim X As Long
    Dim cpt As Variant, N As Long
    Dim d As Object, C As Variant
    Dim lrow As Long
    ThisWorkbook.Worksheets("SelectRecords").Activate
    
Set d = CreateObject("Scripting.Dictionary")
lrow = Sheets("SelectRecords").Range("A65536").End(xlUp).Row + 1

For f = 0 To frmRecordUpdate.lstBox2.ListCount - 1
    
   
    If frmRecordUpdate.lstBox2.Selected(f) = True Then
         
        Sheets("SelectRecords").Range("A" & lrow).Value = lstBox2.List(f, 1)
        lrow = Sheets("SelectRecords").Range("A65536").End(xlUp).Row + 1
    End If
Next f
Set rng = ActiveSheet.Range("A2:A" & lrow)
C = rng
For i = 1 To UBound(C, 1)
  d(C(i, 1)) = 1
Next i
'''''''''''' all of the code above works '''''''''''''''
For X = LBound(d.keys) To UBound(d.keys)
    cpt = d.keys()(X)
    N = Application.WorksheetFunction.CountIf(rng, d.keys()(X))
    frmRecordUpdate.lstSelection.AddItem cpt
    '''' Fails here I select 2 list items. "N" shows 2 ''
    '' when frmRecordUpdate.lstSelection updates ''
    '' the "List valus is replaced by "N" ''
    ' lstselection should show " 66623    2"
    frmRecordUpdate.lstSelection.List(X, 1) = N '''' fails here
    'frmRecordUpdate.CmboPickCpt.AddItem d.keys()(X)
      '  frmRecordUpdate.lstBox2.ColumnCount = 20
      '  frmRecordUpdate.lstBox2.RowSource = ("A3:U" & lrow)
      
Next X
End Sub

For X = LBound(d.keys) To UBound(d.keys) - 1
    cpt = d.keys()(X)
    N = Application.WorksheetFunction.CountIf(rng, d.keys()(X))
    With frmRecordUpdate.lstSelection
        .AddItem cpt
        .List(.ListCount - 1, 1) = N
    End With
    '
    '
    '
Next X