XL 2010 comment passer une selection de cellules excel dans une fonction personaliseé VBA ?

Mathieu Régis

XLDnaute Nouveau
Bonjour à toutes et tous !
Je suis un papi novice en VBA et j'ai un fichier Excel qui contient des colonnes par exemple en "B2: B5" avec des données du style B2 ="4/3/0", B3="2/4/3", B4="1/3/4" et B5="6/0/4".
En B1 je souhaite mettre une fonction du genre : B1 = Function (B2:B5) qui retournerai le résultat suivant : "13/10/11" qui est en fait la somme de chaque nombre dans leur position respective. J'ai écrit la fonction comme ci-dessous mais je n'arrive pas à récuperer ma selection de cellules dans ma Fonction(B2:B5)
Merci de votre aide !

Function Tot_Vertical(champ As Range)
Application.Volatile
'Dim champ As Range
Range(champ).Select

Tot_Repas_Pris = 0
Tot_Repas_Annulé = 0
Tot_Garderie = 0
For Each c In Selection 'Je voudrais récupérer la selection (B2:B5)
Position_1 = InStr(c.Value, "/")
Tot_Repas_Pris = Tot_Repas_Pris + Left(c, InStr(c.Value, "/") - 1)
Position_2 = InStr(Position_1 + 1, c.Value, "/")
Tot_Repas_Annul? = Tot_Repas_Annul? + Mid(c.Value, Position_1 + 1, Position_2 - Position_1 - 1)
Tot_Garderie = Tot_Garderie + Right(c, Len(c) - Position_2)
Next c
'Tot_Vertical = Tot_Repas_Pris & "/" & Tot_Repas_Annul? & "/" & Tot_Garderie
End Function
 

Pièces jointes

  • Total Vertical.xlsm
    17.8 KB · Affichages: 11

job75

XLDnaute Barbatruc
Bonjour Mathieu Régis, bienvenue sur XLD, salut patricktoulon,

Voyez le fichier joint et cette fonction VBA à placer impérativement dans un module standard :
VB:
Function SommeSlash(c As Range)
Application.Volatile
Dim n&, s, a(2)
n = c.End(xlDown).Row - c.Row + 1
If c(2) = "" Then n = 1
For Each c In c.Resize(n)
    s = Split(c, "/")
    For n = 0 To 2
        a(n) = a(n) + Val(s(n))
Next n, c
SommeSlash = a(0) & "/" & a(1) & "/" & a(2)
End Function
Elle est utilisée dans la formule en B1 =SommeSlash(B2)

Edit : j'avais mis une limitation pour le nombre de lignes mais c'est inutile.

A+
 

Pièces jointes

  • SommeSlash(1).xlsm
    21.6 KB · Affichages: 11
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Mathieu Régis,

Le fait que la fonction précédente soit volatile ne me plaît pas car elle est alors recalculée à chaque modification de la feuille.

Pour l'éviter j'utilise maintenant cette macro qui modifie (si nécessaire) l'argument de la fonction :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim f$, c As Range, ad1$, derlig&, ad2$
f = "=SommeSlash("
If FilterMode Then ShowAllData 'si la feuille est filtrée
Application.EnableEvents = False
On Error Resume Next 'si aucune SpeciaCell
For Each c In Cells.SpecialCells(xlCellTypeFormulas)
    If c.Formula Like f & "*" Then
        ad1 = Replace(Replace(c.Formula, f, ""), ")", "")
        derlig = Cells(Rows.Count, c.Column).End(xlUp).Row
        If derlig - c.Row < 2 Then derlig = c.Row + 2 'au moins 2 cellules
        ad2 = c(2).Resize(derlig - c.Row).Address(0, 0)
        If ad1 <> ad2 Then c.Formula = f & ad2 & ")"
    End If
Next
Application.EnableEvents = True
End Sub
L'argument est une plage d'au moins 2 cellules pour qu'on puisse utiliser une matrice (c'est plus rapide) dans la fonction :
VB:
Function SommeSlash(plage As Range) As String
Dim tablo, e, s, n As Byte, a(2)
tablo = plage 'matrice d'au moins 2 éléments, plus rapide
For Each e In tablo
    s = Split(e, "/")
    If UBound(s) > 1 Then
        For n = 0 To 2
            a(n) = a(n) + Val(s(n))
        Next n
    End If
Next e
If a(0) <> "" Then SommeSlash = a(0) & "/" & a(1) & "/" & a(2)
End Function
Par ailleurs la fonction ne renvoie plus de valeur d'erreur si les cellules ne contiennent pas de slash.

Fichier (2).

A+
 

Pièces jointes

  • SommeSlash(2).xlsm
    24.1 KB · Affichages: 9
Dernière édition:

Mathieu Régis

XLDnaute Nouveau
Merci encore ! ça fonctionne très bien mais je n'utilise pas la partie qui renomme la sélection car maintenant je voudrais faire la même chose mais dans le sens horizontal et avec une sélection discontinue comme dans le fichier joint !! est-il donc possible de transmettre à la fonction une sélection de cellules discontinues ?
Merci d'avance de ce que vous pouvez faire pour moi !
Bien cordialement
 

Pièces jointes

  • Tot Horisontal.xlsm
    16.7 KB · Affichages: 3

job75

XLDnaute Barbatruc
VB:
Function Tot(r As Range) As String
Dim s, n As Byte, a(2)
For Each r In r
    s = Split(CStr(r), "/")
    If UBound(s) > 1 Then
        For n = 0 To 2
            a(n) = a(n) + Val(s(n))
        Next n
    End If
Next r
If a(0) <> "" Then Tot = a(0) & "/" & a(1) & "/" & a(2)
End Function
En J5 =Tot((B5;D5;F5;H5))

La fonction n'ayant qu'un seul argument les références des plages constituées de cellules disjointes doivent être mises entre parenthèses.

A+
 

Pièces jointes

  • Tot Horisontal(1).xlsm
    24.5 KB · Affichages: 8

Mathieu Régis

XLDnaute Nouveau
Bonjour Job75
En complément à la fonction et pour peaufiner un peu la présentation des résultats de la fonction je voudrais affecter une couleur différente à chacun des 3 nombres. Si par exemple le résultat est 1/12/2 je voudrais mettre le 1 en rouge, le 12 en bleu et le 2 en vert. Je vois pas comment modifier la fonction pour obtenir ce résultat ?
Auriez-vous une idée ?
D'avance merci beaucoup !
Bien cordialement
Régis
 

job75

XLDnaute Barbatruc
Bien entendu si l'on supprime les formules la mise en forme devient possible.

Voyez ce fichier (2) et la macro dans le code de la feuille :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim h&, P1 As Range, P2 As Range, c As Range, t$, n%, i%
h = UsedRange.Rows.Count + UsedRange.Row - 5
If h < 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set P1 = [B2,D2,F2,H2,J2] 'adapter éventuellement
For Each c In P1
    c = "=Tot(" & c(4).Resize(h).Address & ")"
    c = c 'supprime la formule
Next
Set P2 = [J5].Resize(h) 'adapter éventuellement
P2 = "=REPT(""'""&Tot((RC[-8],RC[-6],RC[-4],RC[-2])),Tot((RC[-8],RC[-6],RC[-4],RC[-2]))<>"""")"
P2 = P2.Value 'supprime les formules
'---mise en couleurs---
For Each c In Union(P1, P2)
    t = c
    If t <> "" Then
        c.Font.ColorIndex = xlAutomatic 'RAZ
        n = 1
        For i = 1 To Len(t)
            If Mid(t, i, 1) = "/" Then
                n = n + 1
            Else
                c.Characters(i, 1).Font.ColorIndex = IIf(n = 1, 3, IIf(n = 2, 5, 4)) 'rouge, bleu, vert
            End If
        Next i
    End If
Next c
Application.EnableEvents = True 'réactive les évènements
End Sub
Elle se déclenche quand on modifie ou valide une cellule quelconque.
 

Pièces jointes

  • Tot Horisontal(2).xlsm
    22.7 KB · Affichages: 8

Mathieu Régis

XLDnaute Nouveau
Bonjour Job75 ,
Vous êtes un pro de VBA !!
1) Merci pour ce complément et sur ce point j'ai une question : est-ce que ça fonctionne également si les cellules "Cantine" de la récap sont remplies avec une formule ?
2) J'ai justement un pb avec la façon de mettre les formules dans ces cellules et pour être plus concret, je joins deux fichiers :
- Un premier fichier qui est le vôtre annoté mais les explications ne me semblent pas très bonnes​
- Un deuxième fichier qui est exactement mon application en totalité. La macro concernée est "Sub CréationOngletRécapMensuelle()" c'est la ligne où je veux mettre la formule qui merde !​
- Le résultat que je voudrais dans la cellule est une formule comme ci-dessous :​
=+'6 Jan au 10 Jan'!Q5+'13 Jan au 17 Jan'!Q5+'20 Jan au 24 Jan'!Q5+'27 Jan au 31 Jan'!Q5&"/"&+'6 Jan au 10 Jan'!R5+'13 Jan au 17 Jan'!R5+'20 Jan au 24 Jan'!R5+'27 Jan au 31 Jan'!R5&"/"&+'6 Jan au 10 Jan'!S5+'13 Jan au 17 Jan'!S5+'20 Jan au 24 Jan'!S5+'27 Jan au 31 Jan'!S5
Je suis conscient que c'est beaucoup vous demander mais si vous pouvez me donner une piste pour que cette formule soit enfin acceptée !! Je dois dire que j'ai tout essayé mais sans succès !
Bien cordialement
RM
 

Pièces jointes

  • Exemple test récap.xlsm
    33 KB · Affichages: 4
  • Modèle Suivi Cantine & Garderie 2 Bis.xlsm
    699.8 KB · Affichages: 3

Discussions similaires

Réponses
9
Affichages
401

Statistiques des forums

Discussions
311 721
Messages
2 081 928
Membres
101 842
dernier inscrit
seb0390