1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
| Option Explicit
'A jouter la référence à microsoft Scripting Runtiome
Sub FusionFeuilles()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim mDico As New Dictionary
Set sh1 = ThisWorkbook.Sheets("Feuil1")
Set sh2 = ThisWorkbook.Sheets("Feuil2")
Set sh3 = ThisWorkbook.Sheets("Feuil3")
Dim i As Integer
'Lecture feuille
i = 2 'Ligne 1 = Titre
While sh1.Cells(i, 1) <> ""
If Not mDico.Exists(sh1.Cells(i, 1).Text) Then
'Cas ou n'existe pas créé l'enregistrement
mDico.Add sh1.Cells(i, 1).Text, sh1.Cells(i, 2).text
Else
'Cas ou existe déjà Incrémente
mDico(sh1.Cells(i, 1).Text) = mDico(sh1.Cells(i, 1).Text) + sh1.Cells(i, 2).Text
End If
i = i + 1 'Ligne suivante
Wend
i = 2 'Ligne 1 = Titre
While sh2.Cells(i, 1) <> ""
If Not mDico.Exists(sh2.Cells(i, 1).Text) Then
'Cas ou n'existe pas créé l'enregistrement
mDico.Add sh2.Cells(i, 1).Text, sh2.Cells(i, 2)
Else
'Cas ou existe déjà Incrémente
mDico(sh2.Cells(i, 1).Text) = mDico(sh2.Cells(i, 1).Text) + sh2.Cells(i, 2).Text
End If
i = i + 1 'Ligne suivante
Wend
sh3.Cells(1, 1) = sh1.Cells(1, 1) 'Copy entête
sh3.Cells(1, 2) = sh1.Cells(1, 2)
For i = 0 To mDico.Count - 1
sh3.Cells(i + 2, 1) = mDico.Keys(i) 'Récupére Nom
sh3.Cells(i + 2, 2) = mDico.Items(i) 'Récupére nombre
Next
End Sub |
Partager