Modification d'un code existant

SERIEUXETCOOL

XLDnaute Occasionnel
Bonjour le Forum,

Je dispose d'un code VBA qui fonctionne très bien sous Excel 2007. Le souci, c'est que je suis débutant sous Excel et que ce code a été créé par une autre personne. J'ai une petite modification du code à faire...mais je n'y parviens pas seul.

Je compte donc sur l'aide d'un utilisateur "assez expérimenté" pour m'aider à modifier simplement ce code.

Voici le code en question :

Code:
Sub ma_big_macro()
  Dim feuille_donnees As String
  Dim colonne_groupes As String, a_partir_ligne As Integer, ecreter_de_combien As Long
  Dim colonnes_moyennes, colonnes_diff
  
  ' ==============================c'est ici que tu définis la feuille des données ==========================================
  feuille_donnees = "Feuil1" ' <<<<<========= le nom exact de la feuille contenant les groupes à traiter
  '===========================================================================================================================
  
  
  
  ' ================================c'est ici, que tu définis les autres paramètres =========================================
  colonne_groupes = "A" '<<<<<<<======== ici : la colonne des groupes
  a_partir_ligne = 1 '<<<<<<============ ici : la ligne où commencent les groupes
  ecreter_de_combien = 4 '<<<<======= ici : de combien écréter en haut et en bas de chaque groupe
  colonnes_moyennes = Array("B", "D", "E", "F") '<<<<=== ici : énumération des colonnes où faire la moyenne ("") si aucune
  colonnes_diff = Array("C") ' <<<<<===== ici : énumération des colonnes où faire tes "différences" ("") si aucune
  col_groupes = Array(colonne_groupes) ' ---->> ça, c'est pour le code. Ne t'en préoccupe pas.
  '==========================================================================================================================
  
  
  ' ________________________________________ les gardes-fou, maintenant ________________________________________________
  
  If ActiveSheet.Name <> feuille_donnees Then
    MsgBox "cette opération ne doit être lancée que si la feuille " & feuille_donnees & " est la feuille active"
    Exit Sub
  End If
  If verif(col_groupes, colonne_groupes, a_partir_ligne, "colonne des groupes") = False Then Exit Sub
  If verif(colonnes_moyennes, colonne_groupes, a_partir_ligne, "colonne à moyenne") = False Then Exit Sub
  If verif(colonnes_diff, colonne_groupes, a_partir_ligne, "colonne à différence") = False Then Exit Sub
  '______________________________________________________________________________________________________________________
  
  
  ' ------------------------------ si l'exécution atteint ce point, c'est que tout est cohérent -------------------------
  ' ------------------------------ on y va donc -------------------------------------------------------------------------
  ' ---------------------------------------------"écrétant" d'abord------------------------------------------------------
  epurer colonne_groupes, a_partir_ligne, ecreter_de_combien
  ' ----------------------------------------puis en traitant le reste (écart(s) et moyenne(s) ---------------------------
  on_amenage colonne_groupes, a_partir_ligne, colonnes_moyennes, colonnes_diff
  
  
End Sub


Public Sub epurer(ByVal col As String, ByVal ligne As Integer, ByVal nb As Integer)
  Dim plage As Range, plage_a_supp As Range
  Dim n As Long, i As Long, j As Long, msg As String
   n = Range(col & Rows.Count).End(xlUp).Row
   If nb = 0 Then Exit Sub
   msg = ""
   For i = ligne + 1 To n + 1
     If Range(col & i).Value = Range(col & i - 1).Value Then
       If plage Is Nothing Then
         Set plage = Union(Range(col & i - 1), Range(col & i))
       Else
         Set plage = Union(plage, Range(col & i))
       End If
     ElseIf Not plage Is Nothing Then
         If plage.Rows.Count >= nb * 2 Then
           For j = 1 To nb
             If plage_a_supp Is Nothing Then
               Set plage_a_supp = Union(plage(1, 1), plage(plage.Rows.Count, 1))
             Else
               Set plage_a_supp = Union(plage_a_supp, plage(j, 1), plage(plage.Rows.Count + 1 - j, 1))
             End If
           Next
           Set plage = Range(col & i)
           If Range(col & i).Value = "" Then Exit For
          Else
            msg = msg & " - " & plage(1, 1).Value
            Set plage = Nothing
            If Range(col & i).Value = "" Then Exit For
          End If
      Else
        msg = msg & " - " & Cells(i - 1, 1).Value
     End If
   Next
   If Not plage_a_supp Is Nothing Then
     plage_a_supp.Rows.EntireRow.Delete
   End If
   If msg <> "" Then
     MsgBox "les groupes suivants, d'un nombre non suffisant, " & _
     "n'ont pas été traités " & vbCrLf & Mid(msg, 3)
   End If
End Sub
Public Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif)
 Dim deb As Long, n As Long, i As Long, combien As Long, k As Long, j As Long
 Dim plage As Range, plage_a_supp As Range
 Dim elmt
 deb = Range(col & ":" & col).Column
 n = Range(col & Rows.Count).End(xlUp).Row
 For i = ld + 1 To n + 1
   If Range(col & i).Value = Range(col & i - 1).Value Then
     If plage Is Nothing Then
       Set plage = Union(Range(col & i - 1), Range(col & i))
     Else
       Set plage = Union(plage, Range(col & i))
     End If
   Else
     If Not plage Is Nothing Then
       combien = plage.Rows.Count
       If combien > 1 Then
         If UBound(moy) > 0 Then
           For Each elmt In moy
             k = Range(elmt & ":" & elmt).Column - deb + 1
             plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k))
           Next
         End If
         If UBound(dif) > 0 Then
           For Each elmt In dif
             k = Range(elmt & ":" & elmt).Column - deb + 1
             plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value
           Next
         End If
         For j = 2 To combien
             If plage_a_supp Is Nothing Then
               Set plage_a_supp = plage(j, 1)
             Else
               Set plage_a_supp = Union(plage_a_supp, plage(j, 1))
             End If
          Next
       End If
       Set plage = Nothing
     End If
   End If
 Next
 If Not plage_a_supp Is Nothing Then
   plage_a_supp.Rows.EntireRow.Delete
 End If
End Sub
Public Function verif(cols, colonne_groupes, a_partir_ligne, descr As String) As Boolean
  verif = True
  If UBound(cols) = 0 Then Exit Function
  derlig = Range(colonne_groupes & Rows.Count).End(xlUp).Row
  For Each elmt In cols
    Dim plage As Range
    Set plage = Nothing
    On Error Resume Next
    Set plage = Range(elmt & a_partir_ligne & ":" & elmt & derlig).SpecialCells(xlCellTypeBlanks)
    If Not plage Is Nothing Then
      MsgBox "la " & descr & " " & elmt & " contient une cellule vide - Corrigez puis relancez, s'il vous plait !"
      verif = False
      On Error GoTo 0
    End If
  Next
End Function

Ce code permet de supprimer un certain nombre de lignes, d'en faire la moyenne et aussi de faire une différence.

De manière générale j'ai une feuille Excel avec les données suivantes :

Colonne1/Colonne2/Colonne3...
0 xxx xxx
0 xxx xxx
0 xxx xxx
1 xxx xxx
1 xxx xxx
1 xxx xxx
2 xxx xxx
2 xxx xxx
2 xxx xxx
3 xxx xxx
3 xxx xxx
3 xxx xxx

-Les données partent de 0 et vont jusqu'à X. X étant un nombre entier connu mais variable. C'est une série de nombre entier, ordonnée du plus petit au plus grand et commençant par 0.
Chaque entier naturel est répété un certain nombre de fois. Dans mon exemple on compte de 0 à 3 en répétant chaque chiffre 3 fois. (c'est un exemple)

-Mon but est de calculer la moyenne sur certaines colonnes de la manière suivante. Je commence avec la première série de 0. Je fais la moyenne sur toute les lignes qui ont pour indice 0, j'insère une ligne, je note la moyenne et je supprimer toutes les valeurs qui m'on servi à calculer la moyenne. Je fais donc la moyenne pour la colonne A, B,C...

-Ensuite je passe à l'entier naturel suivant, les 1. Et ainsi de suite.

-A la fin je souhaite obtenir un fichier ne représentant que les moyennes

Colonne1/Colonne 2/Colonne3....
0 XXX XXXX
1 XXX XXXX
2 XXX XXXX
3 XXX XXXX


Jusque la le code fonctionne très bien. J'ai testé.

Le problème réside sur la fonction pour faire la différence. C'est à dire que je cherche suivant la colonne voulue, à prendre la dernière valeur moins la première. Et en afficher le résultat.

Sur le code présenté ci-dessus, la fonction de différence est bien codée, mais elle ne fonctionne pas quand on fait un test. Sa fait la moyenne et non la différence. Pourtant c'est codée en tant que différence !!!

Il doit y avoir un petit conflit mais je ne parviens pas à le trouver dans le code.

Je ne sais pas si je suis clair dans ma démarche, je reste dans le coin pour les questions éventuelles. A mon sens il ne s'agit que d'une petite modification du code. Rien de plus.

Merci pour votre aide je galère un peu bcp la^^

Cordialement,

André
 

SERIEUXETCOOL

XLDnaute Occasionnel
Re : Modification d'un code existant

Ah pour le fichier il faut attendre ce soir que je le poste. Mon fichier de test est resté sur mon ordi perso. La pouasse.

Néanmoins, je pense que par simple lecture du code que j'ai posté, il est possible de déceler une anomalie de programmation.

Le problème doit se poser, dans la fonction "Public Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif)"

Si vous trouvez pourquoi la "différence" entre la dernière valeur et la première ne fonctionne pas je sus preneur.

J'ai vraiment du mal à exprimer mon problème la. Je le vois bien. Sa ne doit pas être facile pour vous qui lissez ce message. Faut que je poste mon fichier sa sera plus facile.

Merci pour votre aide quand même.

André
 

SERIEUXETCOOL

XLDnaute Occasionnel
Re : Modification d'un code existant

RE dsl du retard, mais j'étais pas mal occupé cette semaine.

Donc me revoilà donc avec le fichier Excel qui contiens le code. Le problème se pose sur la colonne B qui fait les différences.

Une différence étant codée de la manière suivante :

(dernière ligne - première ligne)

- Une première pièce jointe avec la base de donnée que j'utilise. Colonne A pour les groupes, colonne B pour la différence, et colonnes [C;H] pour les moyennes. On commence à partir de la ligne 1 avec suppression des deux premières ET deux dernières lignes pour chaque groupe.

numéro 1

- Une deuxième pièce jointe qui montre le résultat après passage de la Macro complète. Donc après suppression des 2 premières et 2 dernières lignes de chaque groupe, moyenne et différence.

numéro 2

On vois bien que la colonne B qui doit faire les différences...ne fonctionne pas du tout !

Et pour n'avoir aucun doute sur mon raisonnement, je post ici le code qui a été utilisé. Je ne sais vraiment ou j'ai mal utilisé le code sincèrement.

Je dois être aveugle lol. Mais le plus probable reste encore une petite erreur de programmation je pense.

Voici le code VBA :

Code:
Sub SUPPRESSION_MOYENNE_DIFFERENCE()

Cells.Clear ' Vide la feuille

  Dim plage As Range, plage_a_supp As Range
  Dim nb As Long, n As Long, i As Long, j As Long, msg As String
  Dim t, ii As Byte

  t = Split("1 11 21 31") 'Permet de créer une petite table pour exemple
  
  For ii = 0 To 3
     Cells(t(ii), 1).Resize(10) = ii
     Cells(t(ii), 2).Resize(10) = [=TRANSPOSE({1,2,3,4,5,6,7,8,9,10})]
  Next ii
  
    Cells(41, 1).Value = 3
    Cells(42, 1).Value = 3
    Cells(43, 1).Value = 3
    Cells(44, 1).Value = 3
    Cells(45, 1).Value = 3
    Cells(41, 2).Value = 11
    Cells(42, 2).Value = 12
    Cells(43, 2).Value = 13
    Cells(44, 2).Value = 14
    Cells(45, 2).Value = 15
    
    Columns("A:B").Select
    Selection.Copy
    Columns("C:C").Select
    ActiveSheet.Paste
    Columns("A:D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("E:E").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    'Range("A45:H45").Select
    'Selection.ClearContents




  Dim feuille_donnees As String
  Dim colonne_groupes As String, a_partir_ligne As Integer, ecreter_de_combien As Long
  Dim colonnes_moyennes, colonnes_diff
  
  ' ==============================c'est ici que tu définis la feuille des données ==========================================
  feuille_donnees = "Feuil1" ' <<<<<========= le nom exact de la feuille contenant les groupes à traiter
  '===========================================================================================================================
  
  
  
  ' ================================c'est ici, que tu définis les autres paramètres =========================================
  colonne_groupes = "A" '<<<<<<<======== ici : la colonne des groupes
  a_partir_ligne = 1 '<<<<<<============ ici : la ligne où commencent les groupes
  ecreter_de_combien = 2 '<<<<======= ici : de combien écréter en haut et en bas de chaque groupe
  colonnes_moyennes = Array("A", "C", "D", "E", "F", "G", "H") '<<<<=== ici : énumération des colonnes où faire la moyenne ("") si aucune
  colonnes_diff = Array("B") ' <<<<<===== ici : énumération des colonnes où faire tes "différences" ("") si aucune
  col_groupes = Array(colonne_groupes) ' ---->> ça, c'est pour le code. Ne t'en préoccupe pas.
  '==========================================================================================================================
  
  
  ' ________________________________________ les gardes-fou, maintenant ________________________________________________
  
  If ActiveSheet.Name <> feuille_donnees Then
    MsgBox "cette opération ne doit être lancée que si la feuille " & feuille_donnees & " est la feuille active"
    Exit Sub
  End If
  If verif(col_groupes, colonne_groupes, a_partir_ligne, "colonne des groupes") = False Then Exit Sub
  If verif(colonnes_moyennes, colonne_groupes, a_partir_ligne, "colonne à moyenne") = False Then Exit Sub
  If verif(colonnes_diff, colonne_groupes, a_partir_ligne, "colonne à différence") = False Then Exit Sub
  '______________________________________________________________________________________________________________________
  
  
  ' ------------------------------ si l'exécution atteint ce point, c'est que tout est cohérent -------------------------
  ' ------------------------------ on y va donc -------------------------------------------------------------------------
  ' ---------------------------------------------"écrétant" d'abord------------------------------------------------------
  epurer colonne_groupes, a_partir_ligne, ecreter_de_combien
  ' ----------------------------------------puis en traitant le reste (écart(s) et moyenne(s) ---------------------------
  on_amenage colonne_groupes, a_partir_ligne, colonnes_moyennes, colonnes_diff
  
  
End Sub
Public Sub epurer(ByVal col As String, ByVal ligne As Integer, ByVal nb As Integer)
  Dim plage As Range, plage_a_supp As Range
  Dim n As Long, i As Long, j As Long, msg As String
   n = Range(col & Rows.Count).End(xlUp).Row
   If nb = 0 Then Exit Sub
   msg = ""
   For i = ligne + 1 To n + 1
     If Range(col & i).Value = Range(col & i - 1).Value Then
       If plage Is Nothing Then
         Set plage = Union(Range(col & i - 1), Range(col & i))
       Else
         Set plage = Union(plage, Range(col & i))
       End If
     ElseIf Not plage Is Nothing Then
         If plage.Rows.Count >= nb * 2 Then
           For j = 1 To nb
             If plage_a_supp Is Nothing Then
               Set plage_a_supp = Union(plage(1, 1), plage(plage.Rows.Count, 1))
             Else
               Set plage_a_supp = Union(plage_a_supp, plage(j, 1), plage(plage.Rows.Count + 1 - j, 1))
             End If
           Next
           Set plage = Range(col & i)
           If Range(col & i).Value = "" Then Exit For
          Else
            msg = msg & " - " & plage(1, 1).Value
            Set plage = Nothing
            If Range(col & i).Value = "" Then Exit For
          End If
      Else
        msg = msg & " - " & Cells(i - 1, 1).Value
     End If
   Next
   If Not plage_a_supp Is Nothing Then
     plage_a_supp.Rows.EntireRow.Delete
   End If
   If msg <> "" Then
     MsgBox "les groupes suivants, d'un nombre non suffisant, " & _
     "n'ont pas été traités " & vbCrLf & Mid(msg, 3)
   End If
End Sub
Public Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif)
 Dim deb As Long, n As Long, i As Long, combien As Long, k As Long, j As Long
 Dim plage As Range, plage_a_supp As Range
 Dim elmt
 deb = Range(col & ":" & col).Column
 n = Range(col & Rows.Count).End(xlUp).Row
 For i = ld + 1 To n + 1
   If Range(col & i).Value = Range(col & i - 1).Value Then
     If plage Is Nothing Then
       Set plage = Union(Range(col & i - 1), Range(col & i))
     Else
       Set plage = Union(plage, Range(col & i))
     End If
   Else
     If Not plage Is Nothing Then
       combien = plage.Rows.Count
       If combien > 1 Then
         If UBound(moy) > 0 Then
           For Each elmt In moy
             k = Range(elmt & ":" & elmt).Column - deb + 1
             plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k))
           Next
         End If
         If UBound(dif) > 0 Then
           For Each elmt In dif
             k = Range(elmt & ":" & elmt).Column - deb + 1
             plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value
           Next
         End If
         For j = 2 To combien
             If plage_a_supp Is Nothing Then
               Set plage_a_supp = plage(j, 1)
             Else
               Set plage_a_supp = Union(plage_a_supp, plage(j, 1))
             End If
          Next
       End If
       Set plage = Nothing
     End If
   End If
 Next
 If Not plage_a_supp Is Nothing Then
   plage_a_supp.Rows.EntireRow.Delete
 End If
End Sub
Public Function verif(cols, colonne_groupes, a_partir_ligne, descr As String) As Boolean
  verif = True
  If UBound(cols) = 0 Then Exit Function
  derlig = Range(colonne_groupes & Rows.Count).End(xlUp).Row
  For Each elmt In cols
    Dim plage As Range
    Set plage = Nothing
    On Error Resume Next
    Set plage = Range(elmt & a_partir_ligne & ":" & elmt & derlig).SpecialCells(xlCellTypeBlanks)
    If Not plage Is Nothing Then
      MsgBox "la " & descr & " " & elmt & " contient une cellule vide - Corrigez puis relancez, s'il vous plait !"
      verif = False
      On Error GoTo 0
    End If
  Next
End Function



Voila. Et la je bloque sur la fonction différence qui devrait opérer sur la colonne B. Le résultat escompté étant :

Colonne b
(8-3)
(8-3)
(8-3)
(13-3)

Bien cordialement,

André

Ps : Je met également le fichier Excel en pièce jointe
 

Pièces jointes

  • numéro 1.JPG
    numéro 1.JPG
    164.8 KB · Affichages: 64
  • numéro 2.jpg
    numéro 2.jpg
    17.9 KB · Affichages: 54
  • suppression de lignes pour se faire la main.xls
    74.5 KB · Affichages: 47

SERIEUXETCOOL

XLDnaute Occasionnel
Re : Modification d'un code existant

Hummm vraiment personne cette fois-ci pour fixer le bug du code ci-dessus ???

MJ13, tu n'est pas encore passé par ici, ou alors tu n'as pas d'avis sur le sujet ?

Merci à ceux qui pourront m'aiguiller un peu.

André

Ps : Posez les questions que vous voulez. Je reste ici pour essayer de vous aider aussi.
 

Statistiques des forums

Discussions
313 309
Messages
2 097 024
Membres
106 809
dernier inscrit
flopat78