Algoritmo fusione array (bilanciato)

[Picchio75]

Buonasera a tutti,
sto cercando di risolvere un problema e non riesco a trovare la soluzione. Provo a descrivere velocemente il problema.
In un foglio di lavoro EXCEL dati due elenchi di dati (es. colonna A e colonna B) devo creare una terza colonna che sia la fusione delle prime due.
Fin qui tutto bene se non che questa terza colonna deve avere gli elementi di A e B bilanciati ed ordinati, ovvero, l'elenco con elementi minore (es. B) deve essere distribuito nell'elenco totale (C) distribuito equamente tra l'elenco con maggiore elementi (es. A)

Esempio

Colonna A (il trattino - separa gli elementi delle varie caselle)
A-B-C-D-A-B-C-D-A-B-C-D-A-B-C-D

Colonna B (il trattino - separa gli elementi delle varie caselle)
1-2-3-3-4

Il risultato nella colonna C deve essere il seguente:
A-B-C-1-D-A-B-2-C-D-A-3-B-C-D-3-A-B-C-4-D

L'algoritmo potrebbe essere dividere il numero degli elementi della lista maggiore per quello della lista degli elementi minore. Nell'esempio 16:5=3,2
Dispongo gli elementi della lista B ogni 3 elementi della lista A.

Tutto bene se non che quando le liste diventano estremamente lunghe i "resti" che si lasciano per strada pesano alla fine del "merge" facendo si che gli elementi della lista minore si distribuiscano non omogeneamente tra gli elementi della lista maggiore.

Non riesco a trovare l'algoritmo corretto per poter poi codificare la macro in VBA che mi faccia questo lavoro. Qualcuno può aiutarmi?

Grazie
Pablo

[Daniels118]

Vedi se questo codice fa al caso tuo:

Public Sub merge()
Dim s   As Worksheet
Dim na  As Integer
Dim nb  As Integer
Dim a   As Integer
Dim b   As Integer
Dim lb  As Integer
Dim c   As Integer
    Set s = ActiveSheet
    Call clean(s, 3)
    na = conta(s, 1)
    nb = conta(s, 2)
    For a = 1 To na
        b = 1 + (a - 1) / (na - 1) * (nb - 1)
        c = c + 1
        s.Cells(c, 3).Value = s.Cells(a, 1).Value
        If b > lb Then
            c = c + 1
            s.Cells(c, 3).Value = s.Cells(b, 2).Value
            lb = b
        End If
    Next a
End Sub

Private Function conta(s As Worksheet, col As Integer) As Integer
Dim i   As Integer
    i = 1
    Do While s.Cells(i, col).Value <> ""
        i = i + 1
    Loop
    conta = i - 1
End Function

Private Sub clean(s As Worksheet, col As Integer)
Dim i   As Integer
    i = 1
    Do While s.Cells(i, col).Value <> ""
        Call s.Cells(i, col).Clear
        i = i + 1
    Loop
End Sub

[Picchio75]

Funziona.

Grazie 1000 Daniel

Originariamente inviato da Daniels118

Vedi se questo codice fa al caso tuo:

Public Sub merge()
Dim s   As Worksheet
Dim na  As Integer
Dim nb  As Integer
Dim a   As Integer
Dim b   As Integer
Dim lb  As Integer
Dim c   As Integer
    Set s = ActiveSheet
    Call clean(s, 3)
    na = conta(s, 1)
    nb = conta(s, 2)
    For a = 1 To na
        b = 1 + (a - 1) / (na - 1) * (nb - 1)
        c = c + 1
        s.Cells(c, 3).Value = s.Cells(a, 1).Value
        If b > lb Then
            c = c + 1
            s.Cells(c, 3).Value = s.Cells(b, 2).Value
            lb = b
        End If
    Next a
End Sub

Private Function conta(s As Worksheet, col As Integer) As Integer
Dim i   As Integer
    i = 1
    Do While s.Cells(i, col).Value <> ""
        i = i + 1
    Loop
    conta = i - 1
End Function

Private Sub clean(s As Worksheet, col As Integer)
Dim i   As Integer
    i = 1
    Do While s.Cells(i, col).Value <> ""
        Call s.Cells(i, col).Clear
        i = i + 1
    Loop
End Sub