macro insérer lignes et formule "moyenne

mdelbos · 19 Juin 2009

Macro insérer lignes et insérer formule "moyenne"

Bonjour,
J'ai cherché une solution dans le forum mais je ne trouve pas une réponse complète alors je me permets de solliciter votre aide. Voilà mon problème :
J'aurais besoin d'une macro insérant automatiquement des lignes en fonction d'un tri d'une colonne E par exemple et qui insère dans cette ligne ainsi crée un formule moyenne : j'ai un tableau avec des notes, je veux faire la moyenne de ces notes an fonction de l'établissement d'origine (c'est là que le tri opère colonne E).
Je débute totalement en macro....
J'ai joins un exemple de tableau.
Merci par avance pour votre aide

PS: j'ai bien trouvé des macros pour trier et insérer une ligne en fonction de l'établissement mais pas pour intégrer la moyenne...
Voici pour l'instant la macro que j'ai et qui effectue le tri:
Dim DerLig As Long
Dim I As Long

With Sheets("Feuil2")
DerLig = .Range("E65536").End(xlUp).Row
.Cells(DerLig + 1, 5) = "Total " & .Cells(DerLig, 5)
For I = DerLig To 4 Step -1
If .Cells(I - 1, 5) <> .Cells(I, 5) Then
.Rows(I).Insert shift:=xlDown
.Cells(I, 5) = "Total " & .Cells(I - 1, 5)

End If
Next I
End With
End Sub

job75 · 19 Juin 2009

Re : macro insérer lignes et formule "moyenne

Bonjour mdelbos, bienvenue sur XLD,

Voici votre fichier avec la macro :

Code:

Sub Moyenne()
Dim I As Long, plage As Range, cel As Range
With Sheets("Feuil2")
  For I = .Range("E65536").End(xlUp).Row + 1 To 4 Step -1
    If .Cells(I - 1, 5) <> .Cells(I, 5) Then
      If .Cells(I - 1, 5) Like "Moyennes *" Then 'au cas ou les moyennes existent déjà
        I = I - 1
      Else
        .Rows(I).Insert: .Rows(I).Borders(xlInsideVertical).LineStyle = xlNone
      End If
      .Cells(I, 5) = "Moyennes " & .Cells(I - 1, 5)
      If Not plage Is Nothing Then
        For Each cel In plage
          cel.FormulaR1C1 = "=AVERAGE(R[" & I - plage.Row + 1 & "]C:R[-1]C)"
        Next cel
      End If
      Set plage = .Range(.Cells(I, 7), .Cells(I, [COLOR="Red"]36[/COLOR]))
    End If
  Next I
  For Each cel In plage 'il y a encore une ligne de moyennes à remplir...
    cel.FormulaR1C1 = "=AVERAGE(R[" & 3 - plage.Row & "]C:R[-1]C)"
  Next cel
End With
End Sub

La macro peut se lancer par les touches Ctrl+M.

Même si les moyennes sont créées, on peut relancer la macro sans problème.

Edit : s'il le faut, remplacer 36 (en rouge) par 38. Je ne sais pas s'il faut aussi remplir les colonnes AK et AL.

A+

job75 · 19 Juin 2009

Re : macro insérer lignes et formule "moyenne

Re,

On peut simplifier, pas besoin de boucle pour remplir les cellules d'une ligne :

Code:

Sub Moyenne()
Dim I As Long, plage As Range
With Sheets("Feuil2")
  For I = .Range("E65536").End(xlUp).Row + 1 To 4 Step -1
    If .Cells(I - 1, 5) <> .Cells(I, 5) Then
      If .Cells(I - 1, 5) Like "Moyennes *" Then 'au cas ou les moyennes existent déjà
        I = I - 1
      Else
        .Rows(I).Insert: .Rows(I).Borders(xlInsideVertical).LineStyle = xlNone
      End If
      .Cells(I, 5) = "Moyennes " & .Cells(I - 1, 5)
      If Not plage Is Nothing Then _
        [COLOR="Red"]plage.FormulaR1C1[/COLOR] = "=AVERAGE(R[" & I - plage.Row + 1 & "]C:R[-1]C)"
      Set plage = .Range(.Cells(I, 7), .Cells(I, 36))
    End If
  Next I
  [COLOR="Red"]plage.FormulaR1C1[/COLOR] = "=AVERAGE(R[" & 3 - plage.Row & "]C:R[-1]C)" 'il y a encore une ligne de moyennes à remplir...
End With
End Sub

Edit de rappel : on lance la macro par Ctrl+M

A+

mdelbos · 21 Juin 2009

Re : macro insérer lignes et formule "moyenne

Je vais essayer cette macro, effectivement cela va jusqu'aux colonnes AK et AL.
Merci bcp pour votre aide

mdelbos · 21 Juin 2009

Re : macro insérer lignes et formule "moyenne

Cela ne marche pas vraiment car les collèges ne sont pas toujours triés comme il le faut : ci-joint le fichier avec les résultats : toutes les données d'un même collège ne sont pas regroupées ensemble et on trouve du coup plusieurs fois la moyenne de tel établissement......
Merci beaucoup de m'aider...

job75 · 21 Juin 2009

Re : macro insérer lignes et formule "moyenne

Bonjour mdelbos, le forum,

D'accord mdelbos, mais ce nouveau fichier n'est plus le même que le précédent...

1) Adapter la macro à la 1ère ligne à traiter (4).

2) Remplir les cellules de la ligne 3 jusqu'à la dernière pour que l'on puisse déterminer dercol, dernière colonne à remplir.

3) La macro trie le tableau pour que les établissements de même nom soient ensemble, elle trie ensuite par nom des élèves :

Code:

Sub Moyenne()
Dim I As Long, [COLOR="Red"]dercol As Byte,[/COLOR] plage As Range

Application.ScreenUpdating = False
With Sheets("total")

  For I = .Range("E65536").End(xlUp).Row To [COLOR="Red"]4[/COLOR] Step -1
  If .Cells(I, 5) Like "Moyennes *" Then .Cells(I, 5).EntireRow.Delete 'suppression des lignes de moyennes
  Next
[COLOR="Red"]  .Rows("4:65536").Sort Key1:=.Range("E4"), Order1:=xlAscending, _
  Key2:=.Range("A4"), Order2:=xlAscending, Header:=xlNo 'tri du tableau[/COLOR]
  
  [COLOR="Red"]dercol = .Range("IV3").End(xlToLeft).Column 'dernière colonne à remplir[/COLOR]
  For I = .Range("E65536").End(xlUp).Row + 1 To [COLOR="Red"]5[/COLOR] Step -1
    If .Cells(I - 1, 5) <> .Cells(I, 5) Then
      .Rows(I).Insert
      .Rows(I).Borders(xlInsideVertical).LineStyle = xlNone 'supprime les bordures
      .Cells(I, 1).Resize(, dercol).Interior.ColorIndex = 36 'colore la ligne en jaune
      .Cells(I, 5) = "Moyennes " & .Cells(I - 1, 5)
      If Not plage Is Nothing Then _
        plage.FormulaR1C1 = "=AVERAGE(R[" & I - plage.Row + 1 & "]C:R[-1]C)"
      Set plage = .Range(.Cells(I, 7), .Cells(I, [COLOR="Red"]dercol[/COLOR]))
    End If
  Next
  plage.FormulaR1C1 = "=AVERAGE(R[" &[COLOR="Red"] 4 [/COLOR]- plage.Row & "]C:R[-1]C)" 'il y a encore une ligne de moyennes à remplir...

End With
End Sub

Edit : la macro colore les lignes de moyennes en jaune.

A+

macro insérer lignes et formule "moyenne

mdelbos

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

mdelbos

XLDnaute Nouveau

mdelbos

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

macro insérer lignes et formule "moyenne

mdelbos

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

mdelbos

XLDnaute Nouveau

mdelbos

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency