Appliquer un code VBA à plusieurs colonnes

[webmuster]

Bonjour à toutes et à tous

Une fois de plus, je me permets de solliciter votre aide.

- Je tente de compléter ce code, en imposant le format "2 décimales" au résultat de calcul de la moyenne.
- Sur le même principe, j'ai besoin de faire des sommes hedomadaires, en colonnes C, D E et F, sachant que, comme précédemment et suivant les mois, les lignes "Dim" sont variables :

Sub hebdo()
For n = 1 To Range("A" & Rows.Count).End(xlUp).Row
  If Range("A" & n) = "dim" Then
    If n - 6 < 1 Then
      mm = 1
    Else
      mm = n - 6
    End If
    For m = n To mm Step -1
      If Range("G" & m) <> 0 And Range("G" & m) <> "" Then
        tot = tot + Range("G" & m)
        nb = nb + 1
      End If
    Next m
    If tot <> 0 And nb <> 0 Then Range("G" & n) = tot / nb
  End If
  tot = 0
  nb = 0
Next
End Sub

J'ai fait une tentative en déclarant une variable avec "NumCol", mais sans parvenir à l’intégrer au code existant.
Pouvez-vous m'éclairer ?

Vous trouverez, en pièce jointe, un petit fichier exemple.

Bien cordialement

 

[Xwprft]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir Webmuster,

Voici ma proposition.
A+

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Merci beaucoup Xwprft

J'ai tenté d'adapté ton code à mon besoin :

Sub hebdo()

For n = 1 To Range("A" & Rows.Count).End(xlUp).Row  'balayage de toutes les lignes

  If Range("A" & n) = "dim" Then    'seules les lignes "dim" sont traitées
  
    If n - 6 < 1 Then
      mm = 1            'mm = 1ère ligne (si la 1ère semaine du mois n'est pas complète)
    Else
      mm = n - 6          'mm = ligne du lundi précédent ce dimanche
    End If
    
    For NumCol = 3 To 6     'Numcol = "C" to "F"
    
        For pointeur_ligne = n To mm Step -1 'balayage de toutes les lignes de la semaine
    
            If Cells(pointeur_ligne, NumCol) <> 0 And Cells(pointeur_ligne, NumCol) <> "" Then
                tot = tot + Cells(pointeur_ligne, NumCol)  'cumuler les valeurs
                nb = nb + 1    'compter le nombre de valeurs
            End If
            
        Next pointeur_ligne     'boucle sur les lignes de la semaine
    
        If tot <> 0 And nb <> 0 Then   'résultat=moyenne
            Cells(n, NumCol) = tot
            
        End If
        
    tot = 0   'remise à zéro pour la prochaine boucle
    nb = 0
    
    Next NumCol 'boucle sur les colonnes
      
    For NumCol = 7 To 8     'Numcol = "G" to "H"
    
        For pointeur_ligne = n To mm Step -1 'balayage de toutes les lignes de la semaine
    
            If Cells(pointeur_ligne, NumCol) <> 0 And Cells(pointeur_ligne, NumCol) <> "" Then
                tot = tot + Cells(pointeur_ligne, NumCol)  'cumuler les valeurs
                nb = nb + 1    'compter le nombre de valeurs
            End If
            
        Next pointeur_ligne     'boucle sur les lignes de la semaine
    
        If tot <> 0 And nb <> 0 Then   'résultat=moyenne
            Cells(n, NumCol) = tot / nb
            Cells(n, NumCol).NumberFormat = "#,##0.00"
        End If
        
    tot = 0   'remise à zéro pour la prochaine boucle
    nb = 0
    
    Next NumCol 'boucle sur les colonnes
  End If
  
Next n      'boucle sur les lignes du tableau

End Sub

1° peut-on le rendre plus sobre ?

2°

For NumCol = 7 To 8

- Comment, si les colonnes concernées ne sont pas contigües, dois-je rédiger le code ?

3°

'Numcol = "G" to "H"

- Comment ne cibler qu'une seule colonne ?

4° Si le code fonctionne bien, lorsque je relance la macro une seconde fois, le résultat du 1er calcul est pris en compte dans le second.
Comment résoudre ce problème ?

J'espère ne pas abuser de ton temps.

Merci encore

Bien cordialement

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir Xwprft, le forum,

Ma commande ayant évolué, seules les moyennes hebdomadaires sont désormais nécessaires dans mon tableau.
Je suis donc reparti sur ta version initiale, adaptée au vrai fichier, et tout fonctionne parfaitement.

Cependant, la perfection n'étant pas de ce monde, j'ose une ultime question.

Le fichier étant composé de 12 feuilles (une par mois), est-il possible de faire la moyenne d'une semaine répartie sur deux mois, et donc sur deux feuilles ?

PS: pour ma culture personnelle, les réponses à mon message précédent seront malgré tout les bienvenues!

Bien cordialement

 

[Xwprft]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir webmuster,

Je vais d'abord répondre pour ta culture personnelle, avec cette version :

Pour l'autre question (une semaine à cheval sur 2 mois, et donc sur 2 feuilles) c'est pas aussi simple
il faut reprendre l'analyse au départ
Pour le moment je n'ai rien.
Dans le vrai fichier il y a combien de colonnes de données ?
Combien de colonnes où il faut calculer la moyenne ?

A+

 

[Jack2]

Re : Appliquer un code VBA à plusieurs colonnes

Bonjour webmuster, Bonour Xwprft,

Je suis tombé cette nuit sur votre fil. Il est possible de répondre à la demande de webmuster. Pour cela, il faut effectivement connaître la structure du fichier pour savoir sur quelles colonnes il faut calculer les moyennes. Autre question faut-il préparer un fichier contenant les 12 mois en fonction de l'année choisie ?

Dans le fil suivant, il y a des fonctions qui permettent déjà d'avancer :
https://www.excel-downloads.com/threads/alimenter-une-base-de-donnee-excel.212460/
Il ne reste qu'à trouver le premier lundi du mois, ce qui doit certainement exister dans le forum.

A+ Jack2

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir Xwprft, Jack2,

Merci pour l'intérêt que vous portez, tous deux, à ma demande.

Je vous joins un fichier identique, dans sa structure, au tableau final.

Mon besoin est donc bien de calculer la moyenne d'une semaine quand celle-ci est "à cheval" sur 2 mois (soit 2 feuilles).
J'ai cherché en vain dans plusieurs forum sans trouver de réponse à ma requête.

Cordialement

 

[Xwprft]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir webmuster et Jack2,

Je vois dans tes tableaux que tu as des lignes masquées au-dessus du 1er du mois. Il suffit (yaka ) d'y copier les données du mois précédent lorsque tu génères la feuille. Soit y coller les valeurs, soit si les valeurs ne sont pas figées y créer les formules qui vont chercher les données sur la feuille précédente.
Ensuite dans la macro il faut supprimer le test :
If n-6 < 1 Then mm=1
il faut uniquement
mm=n-6
de cette façon on intègre dans le calcul les données sur les lignes masquées qui sont celles du mois précédent.
Pour le moment je n'ai pas le temps de plancher plus dessus.
Si tu as un souci, je repasserai, mais pas tout de suite.
A+

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Bonsoir Xwprft

Après maintes recherches, et suivant vos conseils, j'ai rédigé le code suivant :

Sub sem()

Dim cel As Range

For Each cel In ActiveSheet.Range("D5:D10")
  
  cel.Value = Application.VLookup(CLng(cel.Offset(0, -1)), Worksheets(ActiveSheet.Index - 1).Range("C33:D41"), 2, False)

Next cel

End Sub

Si cette macro sem () fonctionne bien, j'ai un bug quand je lance hebdo () :

Cells(n, NumCol) = tot / nb

Pouvez-vous m'éclairer ?

Je vous joins le fichier modifié.

Cordialement

 

[Jack2]

Re : Appliquer un code VBA à plusieurs colonnes

Bonjour le Fil,

Grâce à Paf https://www.excel-downloads.com/thr...-cellules-reaprties-sur-deux-feuilles.216650/, j'ai une solution à te proposer qui place les formules "en dur", ce qui permet de rester "dynamique" et évite d'avoir à utiliser une macro pour mettre à jour :

Dim Onglet As String

Function JourB11(Jour As String) As Byte
Dim i As Byte
Jours = Array("lun", "mar", "mer", "jeu", "ven", "sam", "dim")
For i = 0 To 6
    If Jours(i) = Jour Then Exit For
Next i
JourB11 = i + 1
End Function


Sub Ajouter_Moyenne()
Dim Jour As String
Dim Deb As Byte, Lig As Byte
Dim i As Integer
Dim MoisEn As Byte
Dim Mois_1 As Byte
Dim MaFormule As String
'Avril par défaut en partant du mois de mai
St = ActiveSheet.Name
Jour = LCase(Left(CStr(Range("B11")), 3))
'MoisEn : mois en cours
MoisEn = 7 - JourB11(Jour)
' Mois_1 : mois précédent
Mois_1 = 5 - MoisEn
Deb = 11 + MoisEn
With Sheets(Onglet)
    Lig = .Range("B1", .Range("B65535").End(xlUp)).Rows.Count
End With
MaFormule = "=average(" & Onglet & "!D41:D" & Lig - Mois_1 & "," & "D11:D" & Deb - 1 & ")"
Range("D" & Deb).Formula = MaFormule
For i = 1 To 3
    Lig = 7 * i + Deb
    Range("D" & Lig).FormulaR1C1 = _
        "=IF(ISERR(AVERAGE(R[-6]C:R[-1]C)),"""",AVERAGE(R[-6]C:R[-1]C))"
    Range("D" & Lig).AutoFill Destination:=Range("D" & Lig & ":L" & Lig), Type:=xlFillCopy
    Range("L" & Lig).Copy Destination:=Range("O" & Lig)
    Application.CutCopyMode = False
Next i

Lig = 28 + Deb
If LCase(Left(Range("B" & Lig), 3)) = "dim" Then
    Range("D" & Lig).FormulaR1C1 = _
        "=IF(ISERR(AVERAGE(R[-6]C:R[-1]C)),"""",AVERAGE(R[-6]C:R[-1]C))"
    Range("D" & Lig).AutoFill Destination:=Range("D" & Lig & ":L" & Lig), Type:=xlFillCopy
    Range("L" & Lig).Copy Destination:=Range("O" & Lig)
    Application.CutCopyMode = False
End If
End Sub


Sub AjouterFeuille()

Application.ScreenUpdating = False

Onglet = ActiveSheet.Name

Sheets(Worksheets.Count).Copy After:=Sheets(Worksheets.Count)
Range("A50") = Year(Range("a50")) & "/" & Month(Range("a50")) + 1 & "/" & 1
        ActiveSheet.Name = Format([a50], "mmmm")
Range("D5:M35,O5:O35") = clearcontent
Range("M11:M35").FormulaR1C1 = _
        "=RC[-9]+RC[-8]+RC[-7]+RC[-6]+RC[-5]+(RC[-4]*REFERENTIEL!R2C2)+(RC[-3]*REFERENTIEL!R3C2)+(RC[-2]*REFERENTIEL!R4C2)+(RC[-1]*REFERENTIEL!R5C2)"
Range("N11:N35").FormulaR1C1 = _
        "=IF(R1C5="""","""",IF(RC[-1]="""","""",100%+(RC[-1]-LOOKUP(février!R1C5,REFERENTIEL!R3C4:R9C4,REFERENTIEL!R3C5:R9C5))/LOOKUP(février!R1C5,REFERENTIEL!R3C4:R9C4,REFERENTIEL!R3C5:R9C5)))"
Range("P11:P35").FormulaR1C1 = _
        "=IF(RC[-1]="""","""",100%+(RC[-1]-LOOKUP(février!R1C5,REFERENTIEL!R3C4:R9C4,REFERENTIEL!R3C6:R9C6))/LOOKUP(février!R1C5,REFERENTIEL!R3C4:R9C4,REFERENTIEL!R3C6:R9C6))"
Range("Q11:Q35").FormulaR1C1 = "=RC[-4]+RC[-2]"

Ajouter_Moyenne

Application.ScreenUpdating = True
End Sub

Je crois que j'ai oublié de régler le cas ou la semaine commence par un dimanche. Si ça pose problème je posterais le correctif;

A+ Jack2

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Merci Jack2

Avant d'explorer ton code, et toujours dans un but didactique, as-tu une idée concernant le bug que je décrivais dans mon message précédent ?

Cells(n, NumCol) = tot / nb

Sub hebdo()

For n = 1 To Range("B" & Rows.Count).End(xlUp).Row  'balayage de toutes les lignes

  If Range("B" & n) = "dim" Then    'seules les lignes "dim" sont traitées
  
    If n - 6 < 1 Then
      mm = 1            'mm = 1ère ligne (si la 1ère semaine du mois n'est pas complète)
    Else
      mm = n - 6          'mm = ligne du lundi précédent ce dimanche
    End If
    
    For NumCol = 4 To 17     'Numcol = "D" to "Q"
    
        For pointeur_ligne = n To mm Step -1 'balayage de toutes les lignes de la semaine
    
            If Cells(pointeur_ligne, NumCol) <> 0 And Cells(pointeur_ligne, NumCol) <> "" Then
            tot = tot + Cells(pointeur_ligne, NumCol)  'cumuler les valeurs
                nb = nb + 1    'compter le nombre de valeurs
            End If
            
        Next pointeur_ligne     'boucle sur les lignes de la semaine
    
        If tot <> 0 And nb <> 0 Then   'résultat=moyenne
            Cells(n, NumCol) = tot / nb
           
        End If
        
    tot = 0   'remise à zéro pour la prochaine boucle
    nb = 0
    
    Next NumCol 'boucle sur les colonnes
      
    
  End If
  
Next n      'boucle sur les lignes du tableau

End Sub

Bien cordialement

 

[Jack2]

Re : Appliquer un code VBA à plusieurs colonnes

Bonjour webmuster,

Je regarde ça demain. J'en profiterai pour joindre le fichier avec la macro complétée (formule généralisée pour le premier dimanche et la vérification mentionnée dans le post d'hier).

EDIT L'erreur vient de la ligne ci-après :

If Cells(pointeur_ligne, NumCol) <> 0 And Cells(pointeur_ligne, NumCol) <> "" Then

Le test IF ne prend pas en compte l'existence de formule dans les cellules (Cells(pointeur_ligne, NumCol) = Cells(pointeur_ligne, NumCol).value)

On peut remplacer cette ligne par la suivante :

If IsNumeric(Cells(pointeur_ligne, NumCol)) Then

Cette fois-ci, on vérifie que la cellule contient un nombre. Si tu ne veux pas compter les zéros :

If IsNumeric(Cells(pointeur_ligne, NumCol)) Then
   If Cells(pointeur_ligne, NumCol) <> 0 Then
      tot = tot + Cells(pointeur_ligne, NumCol)  'cumuler les valeurs
      nb = nb + 1    'compter le nombre de valeurs
    End If
End If

Ne pas mettre If IsNumeric and <> 0 car la vérification se fait simultanément pour les deux If et le IsNumeric ne remplit pus son rôle.

A+ Jack2

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Merci beaucoup Jack2

Je continue à "fouiller" de mon côté.

Cordialement

 

[Jack2]

Re : Appliquer un code VBA à plusieurs colonnes

Re Bonjour webmuster,

Je viens de te répondre dans le post précédent*

RE EDIT Si la formule renvoie une valeur numérique le test If Cells(pointeur_ligne, NumCol) <> 0 And Cells(pointeur_ligne, NumCol) <> "" Then, ça fonctionne. Si tu bloques sur Cells(n, NumCol) = tot / nb ou tot = tot + Cells(pointeur_ligne, NumCol), c'est que la cellule renvoie soit un zéro, soit autre chose (lettre...).

A+ Jack2

 

[webmuster]

Re : Appliquer un code VBA à plusieurs colonnes

Merci Jack2 et désolé

J'avais consulté ton post précédent vraiment très (trop?) rapidement, à un moment guère propice.

If IsNumeric(Cells(pointeur_ligne, NumCol)) Then
If Cells(pointeur_ligne, NumCol) <> 0 Then
tot = tot + Cells(pointeur_ligne, NumCol) 'cumuler les valeurs
nb = nb + 1 'compter le nombre de valeurs
End If
End If

L'adaptation du code que tu m'as proposée fonctionne parfaitement.

Merci encore pour le temps que tu as bien voulu m'accorder.

Bien cordialement