macro regrouper et sommer

Version imprimable

bonjour tout le monde !!
je viens de commencer une macro et je bloque sur une partie des instructions .
je vais détailler mon tableau:
article   trim1  trim2  trim3  trim4  total
c         65     65     684    6465   6846
x         687    68     68     68     6876
x
c
xx
rx
xf
xxs
j'aimerais changer premièrement les codes articles afin de les traduire en famille d'article ,c'est la première fonction remplacer qui tourne sans soucis.

mais la deuxième partie me pose quelques problèmes car je dois regrouper par code article et sommer en même temps les chiffres correspondant afin de les stocker dans la même ligne et supprimer la ligne du deuxième enregistrement .

je vois pas comment récupérer le num de ligne de l'ancien code et qui va être changer afin de pointer dessus pour faire la somme avec le prochain!!!
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Sub Remplacer() Dim Cel As Range Dim Plg As Range Set Plg = Range("A4:A200") For Each Cel In Plg If Cel Like "x*" Then Cel = "yyy" Next Cel 'Call Regrouper (Val, Cel) End Sub 'Sub Regrouper(Plg,Cel) 'je désire regrouper les lignes contenant les yyy et sommer les enregistrement correspondant. 'stocker la somme dans la cellule de la plus petite ligne correspondante au"yyy" 'End Sub
merci beaucoup

Bonjour,
essayes comme ça :
si tu es sur que c'est "x*" et non "*x*",sinon adaptes

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Remplacer()
Dim Cel As Range
Dim Plg As Range, y As Currency, celtot As String
Set Plg = Range("A4:A200")
y = 0
For Each Cel In Plg
  If Cel Like "x*" Then
    If y = 0 Then celtot = Cel(1, 7).Address'à vérifier où coller le résultat
    y = y + Cel(1, 6)
  End If
Next Cel
Range(celtot) = y
End Sub

merci pour votre aide, je pense que je me suis mal exprimé ou compris cotre code car ,ce que je voulais dire :
je veux passer du premier au deuxième tableau .
article  trim1  trim2  trim3  trim4  total    
c           20     10     20     20     90       
x           10     20     10     20     60       
x           10     10     10     10     40
c           20     20     20     20     80
xx
rx
xf
xxs
article  trim1  trim2  trim3  trim4  total
 x          20     30     20     30    100
 c          40     30     40     40    170
c'est pour cela que je voulais faire en deux étapes le remplacement des codes articles avant les regroupements par somme .

26/04/2012, 12h52
casefayere

Envoies un fichier bidon ou une image car visuellement, ça prend la tête, surtout que j'ai la grippe et la tête comme une citrouille
26/04/2012, 14h11
varik

1 pièce(s) jointe(s)

je vous envoie un fichier pour mieux m'expliquer !!

je veux regrouper les références articles en décomposant premièrement le code article et garder juste la partie avant le séparateur "-" seulement pour les articles commençant par la lettre x .

je pense qu'un visuel sur le fichier excel apportera plus de clarté.

merci et bonne convalescence

j'essaie toujours de trouver une alternative car je sais pas si avec un split ,on peut exiger deux conditions :

-une pour appliquer le split que sur les champs qui commencent avec x
-une pour supprimer les caractères juste après le "-" . même le tiret !!

du coup j'ai pensé à une alternative en deux temps :
la première fonction va m'aider à faire une première partie du travail
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 'Sub Test() Dim Pos As Integer Dim I As Long 'dans la colonne B For I = 1 To Range("B" & Rows.Count).End(xlUp).Row With Range("B" & I) Pos = InStr(.Value, "X") If Pos <> 0 Then .Value = Left(.Value, InStr(.Value, "") + 3) End If End With Next I End Sub
ma question est la suivante ; est ce que je peux me baser sur cette fonction pour regrouper les champs concernées et faire la somme tout en supprimant les lignes traités ?

ou il faut que j'appelle une deuxième fonction pour effectuer la suite ?

merci à vous

Le problème est que tu présentes un fichier avec des sommes qui me paraissent fausses, donc je n'ai peut-être pas compris, sinon si j'ai compris, je te propose ce code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub calcul()
Dim dl As Long, tb, x As Long, plg As Range, cel As Range, y As Long
With Sheets("Feuil1")
  dl = .Range("A" & .Rows.Count).End(xlUp).Row
  tb = .Range("A4:g" & dl)
  Set plg = .Range("J4:O8")
  plg.ClearContents
  For Each cel In plg
    For x = 1 To UBound(tb, 1)
      If tb(x, 1) Like cel(1, 0) & "*" Then
        cel(1, 1) = tb(x, 2)
        For y = 2 To 6
          cel(1, y) = cel(1, y) + tb(x, y + 1)
        Next y
      End If
    Next x
  Next cel
End With
End Sub

Je ne dors pas encore malgré ma grippe et préconise une autre solution, tu choisiras, encore faut-il, comme je l'ai déjà écrit, que j'ai compris ta demande
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub calcul2() Dim dl With Sheets("Feuil1") dl = .Range("A" & .Rows.Count).End(xlUp).Row .Range("K4").FormulaR1C1 = "=SUMIF(R4C1:R" & dl & "C1,""=""&RC9&""*"",R4C[-8]:R" & dl & "C[-8])" .Range("K4").Copy .Range("L4:O8,K5:K8").PasteSpecial Paste:=xlPasteFormulas .Range("K4:O8").Copy .Range("K4:O8").PasteSpecial Paste:=xlPasteValues End With End Sub

27/04/2012, 09h47
varik

merci pour votre aide ; je m'excuse pour les chiffres erronées du tableau mais c'était juste pour donner une exemple .

je pense que vous avez compris l'objectif et vous m'avez présenter deux méthodes différentes que je viens de voir que dans la deuxième il faut spécifier la plage d'adresse du tableau de destination .

je pense que j'ai mal présenté ma demande car je voulais générer le tableau qui résume le premier en regroupant les codes articles ou appliquer les formules directement sur le premier tout en effaçant les lignes une fois calculé pour garder à la fin que des codes articles unique avec leur somme total.

merci
27/04/2012, 10h44
casefayere

Bonjour le forum, varik,
Si tu étudies les codes que je t'ai proposé, il suffit d'une adaptation que tu devrais pouvoir faire seul. Tu comprendrais mieux la démarche.

Bonne journée

merci beaucoup et bon rétablissement

j'ai bloqué sur la partie ou il fallait que j'écrive le nouveau tableau , je doute pas de votre code mais de mon interprétation car je suis sur les deux bouts de code que vous m'avez posté , j'essaie de comprendre la formule :

Code:

"=SUMIF(R4C1:R" & dl & "C1,""=""&RC9&""*"",R4C[-8]:R" & dl & "C[-8])"

j'essaie aussi de changer

Code:

tb = .Range("A4:g" & dl)

afin de pas définir une plage par défaut car on sait pas au final combien d'élément distincts sont présents dans le premiers tableau.

j'ai trouvé ce bout de code . avant que j'oublie !! comment peut on exprimer un like de manière a ce qu'il cherchent des chaines de caractères commençant par "X" et de supprimer tout ce qui se trouve après le "-" de cette chaîne.

exemple:

XMLP-153 ==> XMLP
XDFT-485 ==> XDFT

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
52
Public Sub grouper_col()
  Application.ScreenUpdating = False   ' pour aller plus vite
  Set ma_feuille = ThisWorkbook.Sheets("2011(20-80)")
 
  c_in1 = 1  
  l_in1 = 4 
  c_out1 = 10  
  l_out1 = 4  
 
 
  Do While Not IsEmpty(ma_feuille.Cells(l_in1, c_in1))
 
    If (ma_feuille.Cells(l_in1, c_in1 + 7).Value <> "x") Then
 
      val1 = ma_feuille.Cells(l_in1, c_in1)
      val2 = ma_feuille.Cells(l_in1, c_in1 + 1)
 
      ma_feuille.Cells(l_out1, c_out1).Value = val1
       ma_feuille.Cells(l_out1, c_out1 + 1).Value = val2
 
      sum1 = ma_feuille.Cells(l_in1, c_in1 + 2)
      sum2 = ma_feuille.Cells(l_in1, c_in1 + 3)
      sum3 = ma_feuille.Cells(l_in1, c_in1 + 4)
      sum4 = ma_feuille.Cells(l_in1, c_in1 + 5)
      sum5 = ma_feuille.Cells(l_in1, c_in1 + 6)
 
      l_in2 = l_in1 + 1
      Do While Not IsEmpty(ma_feuille.Cells(l_in2, c_in1))
        If (ma_feuille.Cells(l_in2, c_in1).Value = val1 _
            And ma_feuille.Cells(l_in2, c_in1 + 7).Value <> "x") Then
            sum1 = sum1 + ma_feuille.Cells(l_in2, c_in1 + 2).Value
            sum2 = sum2 + ma_feuille.Cells(l_in2, c_in1 + 3).Value
            sum3 = sum3 + ma_feuille.Cells(l_in2, c_in1 + 4).Value
            sum4 = sum4 + ma_feuille.Cells(l_in2, c_in1 + 5).Value
            sum5 = sum5 + ma_feuille.Cells(l_in2, c_in1 + 6).Valu
           ma_feuille.Cells(l_in2, c_in1 + 7).Value = "x"
        End If
        l_in2 = l_in2 + 1
      Loop
      ' Ecrit la somme
      'ma_feuille.Cells(l_out1, c_out1).Value = val1
      ma_feuille.Cells(l_out1, c_out1 + 2).Value = sum1
      ma_feuille.Cells(l_out1, c_out1 + 3).Value = sum2
      ma_feuille.Cells(l_out1, c_out1 + 4).Value = sum3
      ma_feuille.Cells(l_out1, c_out1 + 5).Value = sum4
      ma_feuille.Cells(l_out1, c_out1 + 6).Value = sum5
      l_out1 = l_out1 + 1   
    End If
    l_in1 = l_in1 + 1
  Loop
  Application.ScreenUpdating = True
End Sub

merci encore

Re varik,

Citation:

afin de pas définir une plage par défaut car on sait pas au final combien d'élément distincts sont présents dans le premiers tableau.

Je pense qu'il suffit de passer par deux tableaux, celui que j'ai déjà mis en place "tb" et une collection ou un "Scripting.dictionary" afin d'éliminer les doublons et mettre le résultat dans le tableau à construire (synthèse). Au passage, sans VBA, tu pouvais aussi passer par un TCD, si tu as le temps (vu ma forme et mes obligations), je montrerai comment éliminer les doublons pour construire le deuxième tableau.

Citation:

avant que j'oublie !! comment peut on exprimer un like de manière a ce qu'il cherchent des chaines de caractères commençant par "X"

une méthode :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Option Explicit Option Compare Text 'tu choisis cette option qui ne fait pas de différence majuscules/minuscules ou voir plus bas Sub chcar() Dim y As Long, dl As Long With Sheets("feuil1") dl = .Range("A" & .Rows.Count).End(xlUp).Row For y = 2 To dl If UCase(Range("A" & y)) Like "Z*" Then 'si option compare non spécifié prendre "ucase" MsgBox Split(Range("A" & y), "-")(0) End If Next End With End Sub
bonne journée

27/04/2012, 13h13
varik

merci

je cherche la syntaxe pour récupérer le Résultat du split car je veux remplacer le code précédent par le nouveau .
27/04/2012, 15h37
casefayere

Tu feras ce que tu veux mais voici ma dernière proposition testée, elle vaut ce qu'elle vaut mais elle fonctionne, il suffit de cliquer sur le bouton, ci-joint le fichier
24/05/2012, 11h13
varik

merci beaucoup pour votre aide .