Problema eliminacion elementos

[h0oke]

Aver si por aqui me pueden ayudar:

El enunciado consiste en borra los numeros de una lista que posean mayor cantidad de digitos pares que impares.

El problema que tengo es el siguiente:

N=4
array={1,2,3,4}
array con eliminaciones={1,3}

N=10
array={1,2,3,4,5,6,7,8,9,10}
array con eliminaciones={1,3,4,6,7,9} cuando tendria que ser:
array con eliminaciones={1,3,5,7,9,10}

Y otro error:
array={2,2,5}
array con eliminaciones={2,5}
Es decir cuando existen posiciones iniciales consecutivas, no asi en

array={5,2,2}
array con eliminaciones={5}

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
cnt_p = 0
cnt_i = 0
Dim lista(100) As Integer
Dim elim(100) As Integer
Label1.Caption = "" 'Array
Label2.Caption = "" 'Array con eliminaciones
Label3.Caption = "" 'Posiciones a eliminar
MsgBox "Inicializacion", vbOKOnly
k = 0
cant = InputBox("Cantidad: ")
N = Val(cant)
For i = 1 To N
   entero = InputBox("Numero: ")
   num = Val(entero)
   lista(i) = num
Next
For i = 1 To N
   Label1.Caption = Label1.Caption & lista(i) & ","
Next
For i = 1 To N
   d_num = lista(i) 'Separo los digitos
   While d_num <> 0
       dig = d_num Mod 10
       If dig Mod 2 = 0 Then 'Compruebo si son multiplos pares
           cnt_p = cnt_p + 1
       End If
       If dig Mod 2 <> 0 Then
           cnt_i = cnt_i + 1
       End If
       d_num = d_num \ 10
   Wend
   If cnt_p > cnt_i Then 'Si la cantidad de digitos pares es mayor a las impares
       k = k + 1
       elim(k) = i 'Array que contiene las posiciones
   End If
   cnt_p = 0
   cnt_i = 0
   
Next
For i = 1 To k
   Label3.Caption = Label3.Caption & elim(i) & ","
Next
For i = 1 To k
   pos = elim(i)
   For j = pos To (N - 1)
       lista(j) = lista(j + 1)
   Next
   N = N - 1
Next
For i = 1 To N
   Label2.Caption = Label2.Caption & lista(i) & ","
Next
End Sub

[h0oke]

Solucionado.

Modificaciones:

Código (vb) [Seleccionar] Expandir

If cnt_p > cnt_i Then
     k = k + 1
     elim(k) = i - cnt_elist
     cnt_elist = cnt_elist + 1
End If

Salu2!