XL 2013 toute versions excel projet xlam XLD

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

patricktoulon

XLDnaute Barbatruc
Bonjour à tous allez je lance un chalenge ou plutôt un projet commun

LE XLAM XLD
CE projet consiste en la creation d'un xlam contenant toutes les fonctions persos que vous pourrez proposer
il y aura des commandes dans le ruban appropriée etc ..
si le cœur vous en dit allez y proposez

des fonctions
on créera des descriptions pour le Fx etc...
tout les auteurs des fonctions seront cités dans les description
tout le monde est invité les fortiches et les moins forts toutes les idées sont bonnes a prendre
des interfaces (pas trop gros sinon c'est un applicatif
des dialogues perso etc....
allez y proposez si le cœur vous en dit
Patrick
 
Bonjour à tous
@Gégé-45550
je vais regarder ça
@jurassic pork: et pourquoi voudrais tu que ça ne fonctionne pas
le départ
il y a mes trois fonctions date dans l'onglet formules bouton date 2
démonstration
la video dure que 6 minutes
Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.
 

Pièces jointes

@jurassic pork: et pourquoi voudrais tu que ça ne fonctionne pas
le départ
il y a mes trois fonctions date dans l'onglet formules bouton date 2
Je n'ai pas dit que cela n'allait pas fonctionner mais on peut se poser des questions. Par exemple, Dans quel répertoire l'installer. Et Il y a peut être d'autres questions que les utilisateurs potentiels se posent.
 
Bonjour à tous
Bon comme je vois que l'on part dans tout les sens
on va démarrer avec les cellule
il nous faudrait
une fonction comptant les cellules de couleur
une fonction comptant les cellule d'une certaine couleur
ces fonctions devront renvoyer soit le nombre de cellule soit le tableaux des valeurs

peut être même les deux en une
le nom de la fonction
VB:
Function Nb_Si_Color( rng as range,Couleur as long ,Optional GetTable as boolean=false)

end Function

si vous voyez un autre nom n'hésitez pas à proposer
on va démarrer avec ça après on verra
 
Dernière édition:
peut être même les deux en une
le nom de la fonction
VB:
Function Nb_Si_Color( rng as range,Couleur as long ,Optional GetTable as boolean=false)

end Function

si vous voyez un autre nom n'hésitez pas à proposer
on va démarrer avec ça après on verra
Bonjour, une idée éventuellement

VB:
Function Nb_Si_Color(rng As Range, Optional Couleur As Long = -1, Optional GetTable As Boolean = False) As Variant
    Dim Cell As Range
    Dim Count As Long
    Dim values() As Variant
    Dim i As Long

    If Couleur = -1 Then
        Couleur = ActiveCell.Interior.Color
    End If

    Count = 0
    i = 0

    For Each Cell In rng
        If Cell.Interior.Color = Couleur Then
            Count = Count + 1
            If GetTable Then
                ReDim Preserve values(i)
                values(i) = Cell.Value
                i = i + 1
            End If
        End If
    Next Cell

    If GetTable Then
        Nb_Si_Color = values
    Else
        Nb_Si_Color = Count
    End If
End Function

Sub test1()
Dim result As Long
result = Nb_Si_Color(Range("A1:K10"), RGB(255, 0, 0)) ' Compte les cellules rouges
Debug.Print result
End Sub

Sub test2()
    Dim values As Variant
    Dim i As Long
    Dim sumValues As Double
    Dim selectedColor As Long
    Dim red As Long, green As Long, blue As Long
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim hasValues As Boolean

    Set ws = ActiveSheet
    Set dataRange = ws.UsedRange

    selectedColor = ActiveCell.Interior.Color

    red = selectedColor Mod 256
    green = (selectedColor \ 256) Mod 256
    blue = (selectedColor \ 65536) Mod 256

    values = Nb_Si_Color(dataRange, selectedColor, True)

    sumValues = 0
    hasValues = False
    
    If IsArray(values) Then
        If UBound(values) >= LBound(values) Then
            For i = LBound(values) To UBound(values)
                If Not IsEmpty(values(i)) And values(i) <> "" Then
                    hasValues = True
                    Exit For
                End If
            Next i

            If Not hasValues Then Exit Sub

            Debug.Print "Couleur de la cellule sélectionnée (RGB) : " & red & ", " & green & ", " & blue
            Debug.Print "Valeurs des cellules de la couleur sélectionnée :"

            For i = LBound(values) To UBound(values)
                If Not IsEmpty(values(i)) And values(i) <> "" Then
                    Debug.Print values(i)
                    If IsNumeric(values(i)) Then
                        sumValues = sumValues + CDbl(values(i))
                    End If
                End If
            Next i

            If sumValues <> 0 Then Debug.Print "Somme des valeurs numériques de la couleur sélectionnée : " & sumValues
        End If
    End If
End Sub

Mais je suppose que vous aviez déjà l'idée de votre fonction

Nathe
 
Dernière édition:
bonjour
oui des idées j'en ai plein
mais c'est un projet communautaire que j'ai initié donc toute participation est la bien venu
ajoute moi une condition du genre n'importe quelle couleur et on sera bon on nettoiera après et on consolidera le code ensemble
je relève quand même une erreur de raisonnement
VB:
If Couleur = -1 Then
        Couleur = ActiveCell.Interior.Color
    End If

    Count = 0
    i = 0

    For Each Cell In rng
        If Cell.Interior.Color = Couleur Then

couleur peut être une couleur précise ou n'importe la quelle
en faisant comme tu fait tu prends par défaut celle de l'activecell

merci pour ton retour 👍
 
couleur peut être une couleur précise ou n'importe la quelle
en faisant comme tu fait tu prends par défaut celle de l'activecell

Pas trop compris votre dernière demande, je vous ai rajoutée une sub3, à voir si c'est ce qui était demandé

VB:
Function Nb_Si_Color(rng As Range, Couleur As Long, Optional GetTable As Boolean = False) As Variant
    Dim Cell As Range
    Dim Count As Long
    Dim values() As Variant
    Dim i As Long

    Count = 0
    i = 0

    For Each Cell In rng
        If Cell.Interior.Color = Couleur Then
            Count = Count + 1
            If GetTable Then
                ReDim Preserve values(i)
                values(i) = Cell.Value
                i = i + 1
            End If
        End If
    Next Cell

    If GetTable Then
        Nb_Si_Color = values
    Else
        Nb_Si_Color = Count
    End If
End Function

Sub test1()
Dim result As Long
result = Nb_Si_Color(Range("A1:K10"), RGB(255, 0, 0))
Debug.Print result
End Sub

Sub test2()
    Dim values As Variant
    Dim i As Long
    Dim sumValues As Double
    Dim selectedColor As Long
    Dim red As Long, green As Long, blue As Long
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim hasValues As Boolean

    Set ws = ActiveSheet
    Set dataRange = ws.UsedRange
  
    selectedColor = ActiveCell.Interior.Color

    red = selectedColor Mod 256
    green = (selectedColor \ 256) Mod 256
    blue = (selectedColor \ 65536) Mod 256

    values = Nb_Si_Color(dataRange, selectedColor, True)

    sumValues = 0
    hasValues = False

    If IsArray(values) Then
        If UBound(values) >= LBound(values) Then
            For i = LBound(values) To UBound(values)
                If Not IsEmpty(values(i)) And values(i) <> "" Then
                    hasValues = True
                    Exit For
                End If
            Next i

            If Not hasValues Then Exit Sub

            Debug.Print "Couleur de la cellule sélectionnée (RGB) : " & red & ", " & green & ", " & blue
            Debug.Print "Valeurs des cellules de la couleur sélectionnée :"

            For i = LBound(values) To UBound(values)
                If Not IsEmpty(values(i)) And values(i) <> "" Then
                    Debug.Print values(i)
                    If IsNumeric(values(i)) Then
                        sumValues = sumValues + CDbl(values(i))
                    End If
                End If
            Next i

            If sumValues <> 0 Then Debug.Print "Somme des valeurs numériques de la couleur sélectionnée : " & sumValues
        End If
    End If
End Sub

Sub test3()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim Cell As Range
    Dim colorDict As Object
    Dim colorKey As Variant
    Dim red As Long, green As Long, blue As Long
    Dim values As Variant
    Dim i As Long
    Dim sumValues As Double

    Set colorDict = CreateObject("Scripting.Dictionary")

    Set ws = ActiveSheet
    Set dataRange = ws.UsedRange

    For Each Cell In dataRange
        If Cell.Interior.Color <> RGB(255, 255, 255) Then
            colorKey = Cell.Interior.Color

            If Not colorDict.Exists(colorKey) Then
                colorDict.Add colorKey, 0
            End If

            If IsNumeric(Cell.Value) Then
                colorDict(colorKey) = colorDict(colorKey) + CDbl(Cell.Value)
            End If
        End If
    Next Cell

    For Each colorKey In colorDict.Keys

        red = colorKey Mod 256
        green = (colorKey \ 256) Mod 256
        blue = (colorKey \ 65536) Mod 256

        Debug.Print "Couleur (RGB) : " & red & ", " & green & ", " & blue & " | Somme des valeurs : " & colorDict(colorKey)
    Next colorKey
End Sub

Nathe
 

Pièces jointes

Dernière édition:
Bonjour patricktoulon,
Bonjour à toutes et tous,

Merci pour cette initiative
J'utilise cette fonction

Somme couleur marche avec MFC

VB:
Function SOMMECOULEURS(PLAGE As Range, Couleur As Range) As Double

Dim COUL As Long

Dim c As Range

Dim colsum As Double

COUL = Couleur.Interior.ColorIndex

For Each c In PLAGE

If PLAGE.Parent.Evaluate("DColorIndex(" & c.Address & ")") = COUL Then

colsum = colsum + c.Value

End If

Next c

SOMMECOULEURS = colsum

End Function

Private Function DColorIndex(r As Range) As Long

DColorIndex = r.DisplayFormat.Interior.ColorIndex

End Function


J'utilise aussi souvent ces deux fonctions qui clonent les fonctions des Excel récents
Fonctions clone texte.avant texte.après
=texteavant (A1;"#";2)
AI = Texte
"#" = Délimiteur
2 =occurence souhaitée du délimiteur, par défaut 1. nombre négatif de recherche à partir de la fin

Code:
Function TexteAvant(str As String, delim As String, Optional occurrence As Long = 1) As String

Dim parts() As String

Dim i As Long

Dim count As Long


' Diviser la chaîne en parties en utilisant le délimiteur

parts = Split(str, delim)


' Si l'occurrence est négative, compter à partir de la fin

If occurrence < 0 Then

occurrence = UBound(parts) + occurrence + 1

End If


' Construire le résultat en ajoutant les parties jusqu'à l'occurrence souhaitée

For i = LBound(parts) To UBound(parts)

If i < occurrence Then

TexteAvant = TexteAvant & parts(i)

If i < occurrence - 1 Then

TexteAvant = TexteAvant & delim

End If

Else

Exit For

End If

Next i

End Function

Function TexteAprès(ByVal texte As String, ByVal délimiteur As String, Optional ByVal occurrence As Long = 1) As String

Dim position As Long

Dim i As Long

Dim startPos As Long


' Si l'occurrence est négative, on cherche à partir de la fin

If occurrence < 0 Then

startPos = Len(texte)

For i = 1 To Abs(occurrence)

position = InStrRev(texte, délimiteur, startPos)

If position = 0 Then Exit For

startPos = position - 1

Next i

Else

startPos = 1

For i = 1 To occurrence

position = InStr(startPos, texte, délimiteur)

If position = 0 Then Exit For

startPos = position + Len(délimiteur)

Next i

End If


' Si la position est trouvée, retourner le texte après le délimiteur

If position > 0 Then

TexteAprès = Mid(texte, position + Len(délimiteur))

Else

TexteAprès = ""

End If

End Function
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour