Macro Vba pour faire la concaténation et la somme des cellules

Version imprimable

Bonjour à tous, forum bonjour,

J'ai un tableau qui se présente ainsi

A090 JL20 C12910 C12910-01N B75 40

A090 JL20 C12910 C12910-01N B75 40

A090 JL20 C12910 C12910-01N B75 40

A090 JL20 C12910 C12910-01N B75 40

A090 JL20 C12910 C12910-01N C75 40

A090 JL20 C12910 C12910-01N C75 40

A090 JL20 C12910 C12910-01N D75 40

A090 JL20 C12910 C12910-01N E75 40

A090 JL20 C12910 C12910-01N E75 40

Je souhaiterais faire la somme et la concaténation de ce tableau afin d'obtenir un autre comme suie :

A090 JL20 C12910 C12910-01N B75 160

A090 JL20 C12910 C12910-01N C75 80

A090 JL20 C12910 C12910-01N D75 40

A090 JL20 C12910 C12910-01N E75 80

J’en appel à votre aimable soutien si quelqu’un avait la solution
Merci

25/12/2018, 09h27
a_diard

Bonjour

Si j'ai bien compris tu devrais avoir un total de 160 pour les 4 premières lignes ??????

Joyaux Noel.
25/12/2018, 09h50
le_dabbabi

D'abord merci pour votre réponse,
La 5e colonne indique le nom d'un ouvrier.
La 6e colonne indique la quantité travaillée par ce dernier.
L'idée, c'est de parcourir la 5e colonne, supprimer les doublons et mettre la somme dans la 6e colonne. Autrement dit, c'est d'avoir la quantité totale travaillée par cet ouvrier.

Merci et joyeux noël.

1 pièce(s) jointe(s)

sbeh el khir, bonjour à tous
essaye avec :

Code:

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
Sub Testtt()
Application.ScreenUpdating = False 'juste pour arrêter affichage écran et améliorer le temps d'exécution du macro
 
'************************************************************************************************************************
Dim unique As New Collection
Dim i As Integer
On Error Resume Next
For Each Cel In Range("E1:E" & [E65000].End(xlUp).Row)
If Cells(Cel.Row, 5) <> "" Then
    unique.Add Cel.Value, CStr(Cel.Value)
    End If
Next Cel
With Sheets("feuil2")
.Activate
On Error GoTo 0
For i = 1 To unique.Count
.Cells(i, 5) = unique(i)
Next i
dernligne = .Range("E" & Rows.Count).End(xlUp).Row
TABLO = Sheets("feuil1").Range("A1", "F" & Sheets("feuil1").Range("F" & Sheets("feuil1").Rows.Count).End(xlUp).Row)
Dim somme As Variant
For j = 1 To dernligne
somme = 0
For i = LBound(TABLO, 1) To UBound(TABLO, 1)
             If .Cells(j, 5) = TABLO(i, 5) Then
                somme = somme + TABLO(i, 6)
                .Cells(j, 6) = somme
                .Cells(j, 1) = TABLO(i, 1)
                .Cells(j, 2) = TABLO(i, 2)
                .Cells(j, 3) = TABLO(i, 3)
                .Cells(j, 4) = TABLO(i, 4)
 
             End If
  Next i
  Next j
 End With
Sheets("feuil2").Select
 
MsgBox ("Regroupement effectué avec succès .... ")
Application.ScreenUpdating = True
End Sub

fichier à tester

25/12/2018, 10h41
Theze

Bonjour,

Tu es sûr de ton second tableau, qu'en première ligne le total est 40 plutôt que 160 ?

Citation:

Envoyé par BENNASR

fichier à tester

Tout d'abord ,veillez excusée, je ne suis pas un informaticien , je suis qu'un débutant en VBA :(
Merci beaucoup ça fonctionne très bien juste un petit détails que j'ai oublié de le dire dé le début.
Le fichier que vous venez de me l'envoyer fonctionner très bien pour un tableau mono référence la 4e colonne, c'est la colonne des références.
Exemple :

Tableau initial

A090 Jl20 C12910 C12910-01N B75 40

A090 Jl20 C12910 C12910-01N B75 40

A090 Jl20 C12910 C12910-011 B75 40

A090 Jl20 C12910 C12910-011 B75 40

A090 Jl20 C12910 C12910-011 D75 40

A090 Jl20 C12910 C12910-011 D75 40

A090 Jl20 C12910 C12910-011 E75 40

A090 Jl20 C15710 C15710-011 D75 40

A090 Jl20 C15710 C15710-011 D75 40

A090 Jl20 C15710 C15710-011 D75 40

Tableau final :

A090 Jl20 C12910 C12910-01N B75 80

A090 Jl20 C12910 C12910-011 B75 80

A090 Jl20 C12910 C12910-011 D75 80

A090 Jl20 C12910 C12910-011 E75 40

A090 Jl20 C15710 C15710-011 D75 120

J’espère que j'ai bien expliqué et que je n'ai rien oublié :P

25/12/2018, 11h32
le_dabbabi

Citation:

Envoyé par Theze

Bonjour,

Tu es sûr de ton second tableau, qu'en première ligne le total est 40 plutôt que 160 ?

Oui, vous avez raison, je viens de la corriger merci.
25/12/2018, 11h36
BENNASR

re

Citation:

je ne suis pas un informaticien , je suis qu'un débutant en VBA

Moi aussi autodidacte
C15710-011 D75 40
c'est pas 120 ????

La dernière ligne du tableau final normalement 120 non???
25/12/2018, 11h46
le_dabbabi

Citation:

Envoyé par BENNASR

La dernière ligne du tableau final normalement 120 non???

Oui oui désole une autre fois.
25/12/2018, 11h57
BENNASR

Aller chercher un petit coin de repas pour manger et puis on verra :aie:
25/12/2018, 11h59
Patrice740

1 pièce(s) jointe(s)

Bonjour,

Ne serait-il pas plus simple d'utiliser un TCD ?
Pas besoin de macro ...
Pièce jointe 436846
25/12/2018, 11h59
le_dabbabi

Citation:

Envoyé par BENNASR

Aller chercher un petit coin de repas pour manger et puis on verra :aie:

:ptdr: Merci bonne appétit

1 pièce(s) jointe(s)

re cousin
je suis pas pro VBA et tout ce que j'ai appris c'est grasse à ce super site ; il y a la méthode des dictionnaires vivement recommandée par les experts du site mais malheureusement je la maitrise pas :aie: :aie:
voila une proposition à tester et à améliorer si nécessaire

Code:

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
51
Sub Testtt()
Application.ScreenUpdating = False 'juste pour arrêter affichage écran et améliorer le temps d'exécution du macro
 
'***********************************Effacer Enciennes Données
With Sheets("Feuil2")
.Cells.ClearContents
End With
'************************************ Collecter Col4 & Col 5 sans doublons
Dim unique As New Collection
Dim i As Integer
On Error Resume Next
For Each Cel In Range("D1:D" & [D65000].End(xlUp).Row)
If Cells(Cel.Row, 5) <> "" Then
    unique.Add Cel.Value & ";" & Cel.Offset(, 1).Value, CStr(Cel.Value) & ";" & Cel.Offset(, 1).Value
    End If
Next Cel
'*********************************** Envoie vers Feuil2 pour remplir colonne D et E
With Sheets("feuil2")
.Activate
On Error GoTo 0
L = 1
 
For i = 1 To unique.Count
.Cells(L, 4) = Split(unique(i), ";")
.Cells(L, 5) = Right(unique(i), 3)
L = L + 1
Next i
 
dernligne = .Range("E" & Rows.Count).End(xlUp).Row
 
' *************************************** Remplir le reste du tableau en fonction de la colonne D et E
TABLO = Sheets("feuil1").Range("A1", "F" & Sheets("feuil1").Range("F" & Sheets("feuil1").Rows.Count).End(xlUp).Row)
Dim somme As Variant
For j = 1 To dernligne
    For i = LBound(TABLO, 1) To UBound(TABLO, 1)
             If .Cells(j, 5) = TABLO(i, 5) And .Cells(j, 4) = TABLO(i, 4) Then
                 somme = somme + TABLO(i, 6)
                .Cells(j, 6) = somme
                .Cells(j, 1) = TABLO(i, 1)
                .Cells(j, 2) = TABLO(i, 2)
                .Cells(j, 3) = TABLO(i, 3)
             End If
      Next i
     somme = 0
      Next j
 End With
Sheets("feuil2").Select
 
MsgBox ("Regroupement effectué avec succès .... ")
Application.ScreenUpdating = True
End Sub

Une tentative avec dictionnaire qui fonctionne (nécessite beaucoup d'amélioration)

Code:

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
Sub testbildic()
Application.ScreenUpdating = False 'juste pour arrêter affichage écran et améliorer le temps d'exécution du macro
 
'***********************************Effacer Enciennes Données
With Sheets("Feuil2")
.Cells.ClearContents
End With
Dim T
Set dico = CreateObject("Scripting.dictionary")
With Sheets("Feuil1")
        dernl = .Range("D" & .Rows.Count).End(xlUp).Row
                For j = 1 To dernl
                 x = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                 dico(x) = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                Next j
Cle = dico.Keys
L = 1
tablo = .Range("A1", "F" & .Range("F" & .Rows.Count).End(xlUp).Row)
End With
 
With Sheets("feuil2")
    For i = 0 To dico.Count - 1
        T = Split(dico(Cle(i)), ";")
        .Cells(L, 1).Value = Cle(i)
        .Cells(L, 1).Value = T(0)
        .Cells(L, 2).Value = T(1)
        .Cells(L, 3).Value = T(2)
        .Cells(L, 4).Value = T(3)
        .Cells(L, 5).Value = T(4)
        L = L + 1
    Next
dernligne = .Range("D" & .Rows.Count).End(xlUp).Row
 
Dim somme As Variant
For j = 1 To dernligne
   For i = LBound(tablo, 1) To UBound(tablo, 1)
             If .Cells(j, 5) = tablo(i, 5) And .Cells(j, 4) = tablo(i, 4) Then
                 somme = somme + tablo(i, 6)
                .Cells(j, 6) = somme
              End If
      Next i
     somme = 0
 Next j
End With
Sheets("feuil2").Select
End Sub

26/12/2018, 08h10
le_dabbabi

Citation:

Envoyé par Patrice740

Bonjour,

Ne serait-il pas plus simple d'utiliser un TCD ?
Pas besoin de macro ...
Pièce jointe 436846

Merci pour votre proposition , malheureusement je ne peux pas utiliser un TDC vu que ce tableau va subir une autre modification .

1 pièce(s) jointe(s)

Citation:

Envoyé par BENNASR

Une tentative avec dictionnaire qui fonctionne (nécessite beaucoup d'amélioration)

Code:

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
Sub testbildic()
Application.ScreenUpdating = False 'juste pour arrêter affichage écran et améliorer le temps d'exécution du macro
 
'***********************************Effacer Enciennes Données
With Sheets("Feuil2")
.Cells.ClearContents
End With
Dim T
Set dico = CreateObject("Scripting.dictionary")
With Sheets("Feuil1")
        dernl = .Range("D" & .Rows.Count).End(xlUp).Row
                For j = 1 To dernl
                 x = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                 dico(x) = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                Next j
Cle = dico.Keys
L = 1
tablo = .Range("A1", "F" & .Range("F" & .Rows.Count).End(xlUp).Row)
End With
 
With Sheets("feuil2")
    For i = 0 To dico.Count - 1
        T = Split(dico(Cle(i)), ";")
        .Cells(L, 1).Value = Cle(i)
        .Cells(L, 1).Value = T(0)
        .Cells(L, 2).Value = T(1)
        .Cells(L, 3).Value = T(2)
        .Cells(L, 4).Value = T(3)
        .Cells(L, 5).Value = T(4)
        L = L + 1
    Next
dernligne = .Range("D" & .Rows.Count).End(xlUp).Row
 
Dim somme As Variant
For j = 1 To dernligne
   For i = LBound(tablo, 1) To UBound(tablo, 1)
             If .Cells(j, 5) = tablo(i, 5) And .Cells(j, 4) = tablo(i, 4) Then
                 somme = somme + tablo(i, 6)
                .Cells(j, 6) = somme
              End If
      Next i
     somme = 0
 Next j
End With
Sheets("feuil2").Select
End Sub

Bonjour et merci pour votre réponse , bah vraiment bizarre lorsque j'ai essayé le fichier avec le tableau que vous me l'avez envoyer ca marche parfaitement, mais lorsque j'ai changé le tableau ca n'a pas marché vous trouverez ci-joint la résultat obtenu tant qu'avec la deuxième macro ça a fonctionner parfaitement

26/12/2018, 08h49
BENNASR

1 pièce(s) jointe(s)

Bonjour cousin
Il est recommandé de travailler avec la deuxième code basé sur les dictionnaire... ce code aussi nécessite des améliorations mais c'est les limites de mes connaissance VBA... Mais pour savoir pourquoi le premier code ne fonctionne pas ... dans ton fichier initial tu écris B75 ou B85 ou autre sans espace et sur trois caractère c'est pourquoi j'ai extrais cette partie avec :

Code:

.Cells(L, 5) = Right(unique(i), 3)

Alors dans ton deuxième fichier tu écris avec un espace entre la lettre et les deux chiffres ... donc il faut écrire :

Code:

.Cells(L, 5) = Right(unique(i), 4)

donc ce code vous induira en erreur chaque fois la forme de la colonne val gr change c'est pourquoi il est recommandé de travailler avec le deuxième code qui fonctionne quelque soit la forme de ce code
voici ton fichier avec les deux code et les deux boutons de commande à tester et si c'est RÉSOLU merci de cliquer en bas sur le bouton approprié
26/12/2018, 09h31
le_dabbabi

ça fonctionne à merveille merci infiniment

A090	JL20	C12910	C12910-01N	B75	40
A090	JL20	C12910	C12910-01N	B75	40
A090	JL20	C12910	C12910-01N	B75	40
A090	JL20	C12910	C12910-01N	B75	40
A090	JL20	C12910	C12910-01N	C75	40
A090	JL20	C12910	C12910-01N	C75	40
A090	JL20	C12910	C12910-01N	D75	40
A090	JL20	C12910	C12910-01N	E75	40
A090	JL20	C12910	C12910-01N	E75	40