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

[Mathieu Régis]

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

 

[patricktoulon]

bonjour si la selection doit etre variante oublie la formule et utilise l’événement selection_change en vba
maintenant si c'est toujours b2:b5 oui

 

[job75]

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

Voyez le fichier joint et cette fonction VBA à placer impérativement dans un module standard :

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+

 

[Mathieu Régis]

Super ! Merci tout plein, c'est exactement ce qu'il me faut.
Bien cordialement

 

[job75]

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 :

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 :

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+

 

[job75]

J'ai testé la fonction sur une plage de 1 048 000 lignes.

Avec la matrice le recalcul s'effectue chez moi en 4,8 secondes contre 7 secondes si l'on traite les cellules.

 

[Mathieu Régis]

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

 

[job75]

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+

 

[Mathieu Régis]

Super, cette fois c'est parfait ! Merci beaucoup Mr.
Très cordialement

 

[Mathieu Régis]

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]

Bonjour Mathieu Régis, le forum,

La mise en forme partielle du contenu d'une cellule n'est pas possible si la cellule contient une formule.

Bon week-end.

 

[Mathieu Régis]

Ok c'est clair ! Merci et bon WE également !

 

[job75]

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 :

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.

 

[Mathieu Régis]

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

 

[job75]

j'ai une question : est-ce que ça fonctionne également si les cellules "Cantine" de la récap sont remplies avec une formule ?

Pourquoi poser une telle question, mettez des formules dans ces colonnes et vous verrez bien.