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


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