Discussion :

[goldab]

J'aimerais fusionner les informations se trouvant sur plusieurs feuilles de mon classer Excel comme ça; merci bp:

Ex:

feuil1:

NOM         POINT
ARTHUR       8
SYLVAIN      9
JEROME       7

feuil2:

NOM       POINT
NICOLAS    8
JEROME     10

RESULAT SOUHAITE :

Feuil3:

NOM       POINT
ARTHUR     8
NICOLAS    8
SYLVAIN    9
JEROME     17

[gFZT82]

Bonjour,

Voici une solution avec une copie feuille après feuille des noms et des points associés.
Si le nom n’est pas présent dans la feuille 3, on le note avec les points associés.
Dans le cas contraire, on ajoute simplement les points associés.
En fin de traitement, on effectue un tri des données.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
Sub test()
Dim WsS As Worksheet, WsC As Worksheet
Dim i As Long, LigneAjout As Long
Dim C As Range
    Application.ScreenUpdating = False
    Set WsC = Worksheets("Feuil3")
    For Each WsS In Worksheets
        If WsS.Name <> "Feuil3" Then
            For i = 2 To WsS.Range("A" & Rows.Count).End(xlUp).Row
                If Application.CountIf(WsC.Columns(1), WsS.Range("A" & i).Value) = 0 Then
                    LigneAjout = WsC.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
                    WsC.Range("A" & LigneAjout) = WsS.Range("A" & i).Value
                    WsC.Range("B" & LigneAjout) = WsS.Range("A" & i).Offset(0, 1).Value
                Else
                    Set C = WsC.Columns(1).Find(WsS.Range("A" & i).Value, , xlValues, xlWhole)
                    If Not C Is Nothing Then
                        C.Offset(0, 1).Value = C.Offset(0, 1).Value + WsS.Range("A" & i).Offset(0, 1).Value
                    End If
                End If
            Next i
        End If
    Next WsS
    With WsC.Sort
        .SortFields.Clear
        .SortFields.Add Key:=WsC.Range("B2:B" & WsC.Range("B" & Rows.Count).End(xlUp).Row), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange WsC.Range("A1:B" & WsC.Range("A" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Cordialement.

[nibledispo]

Bonjour gFZT82,

Je n'ai pas encore la compétence suffisante pour analyser ta solution mais prévoit-elle le cas où le Jérôme feuil1 n'est pas la même personne que son homologue feuil2.
je pense que goldab a dû prévoir cette éventualité et donner un code à chaque individu.

Cordialement.

[gFZT82]

Bonjour nibledispo,

Si Jérôme feuil1 n'est pas la même personne que son homologue feuil2, l'identifiant devra forcément être différent puisque la finalité c'est de balayer toutes les feuilles afin de cumuler les points de Jérôme.
En clair, tu ne peut pas affecter le même identifiant à 2 personnes différentes : tu devras déclarer par exemple Jérôme1 et Jérôme2.

Cordialement.

[SfJ5Rpw8]

Bonsoir,

Une autre solution en utilisant un objet dictionary et sa clé unique

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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