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
 

Fichiers joints

patricktoulon

XLDnaute Impliqué
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

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+
 

Fichiers joints

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+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
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.
 
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
 

Fichiers joints

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+
 

Fichiers joints

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
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.
 

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.
 

Fichiers joints

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
 

Fichiers joints

Discussions similaires


Haut Bas