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}

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