[VBA UDF] Concaténation particulière

Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir le forum

Je séche sur ce petit problème
Je voudrais concaténer des nombres (dans l'exemple de 1 à 16) selon la valeur d'une cellule.
J'y suis presque.
La particularité, c'est que quand les nombres sont consécutifs, la valeur retournée soit par exemple
1 à 16 (au lieu de 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16)
2 à 8 (au lieu de 2,3,4,5,6,7,8)

Ce code ci-dessous reflète mes essais en l'état.
Je pense qu'il y a beaucoup plus simple comme syntaxe.
NB: je joindrai des données exemples plus tard car je dois m'absenter pour le repas de Noel de ma boite qui commençait à 19h.
Heureusement qu'il y a le métro.
VB: 
Function CONCATSI(CriteriaRange As Range, Condition As Variant, ConcatenateRange As Range, Optional Separator As String = ",") As Variant
Dim xResult As String, i, t, x, aa, bb, zz$
aa = Array(6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)
bb = Array(21, 28, 36, 45, 55, 66, 78, 91, 105, 120, 136)
On Error Resume Next
If CriteriaRange.Count <> ConcatenateRange.Count Then
CONCATSI = CVErr(xlErrRef)
Exit Function
End If
For i = 1 To CriteriaRange.Count
If CriteriaRange.Cells(i).Value = Condition Then
xResult = xResult & Separator & ConcatenateRange.Cells(i).Value
End If
Next i
If xResult <> "" Then
'x = VBA.Mid(xResult, 2, Len(xResult) - 1)
'Debug.Print x
t = Split(xResult, ",")
If UBound(t) > 5 And Len(xResult) > 1 And (t(UBound(t)) - 1) / (UBound(t) - 1) = 1 Then
xResult = "1 à " & Application.Index(aa, Application.Match((UBound(t) * (1 + UBound(t)) / 2), bb, 0))
Else
'xResult = VBA.Mid(xResult, VBA.Len(Separator) + 1)
'MsgBox Len(xResult) & "o"
xResult = VBA.Mid(xResult, 2, VBA.Len(xResult) + 1)
End If
End If
CONCATSI = xResult
'Exit Function
End Function
 
Dernière édition:
Solution
Staple1600
Bonsoir le fil, le forum

En attendant les outrages lipidiques et glucides du réveillon, j'ai creusé cette histoire de concaténation, et je suis tombé sur ce genre de syntaxe (que j'ai déjà lu ici sur XLD notamment dans les codes de klin89)
Donc je poste le résultat de ma récréation du jour
VB: 
    Function CONCATSI(Condition, rng As Range, rng2 As Range, Optional Sep As String = ",")
    If Not IsNumeric(Condition) Then Condition = Chr(34) & Condition & Chr(34)
    With rng
    CONCATSI = _
    Join(Filter(.Parent.Evaluate("TRANSPOSE(IF(" & .Columns(1).Address & "=" & Condition & "," & rng2.Address & "))"), False, 0), Sep)
    End With
    End Function
La syntaxe d'utilisation étant par exemple ...
Trier par date Trier par votes
eriiic

eriiic

XLDnaute Barbatruc
Bonjour,

J'ai compris le début de la question mais après tu m'as largué avec tes conditions et ton code, surtout sans un exemple d'application.
Je m'en suis tenu donc à :
la valeur retournée soit par exemple 1 à 16 (au lieu de 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16)
Cliquez pour agrandir...
.
Le principe : créer une union de lignes et parcourir les areas pour extraire les plages consécutives.
VB: 
Sub concat()
    Dim aa, i As Long, pl As Range, pl2 As Range, resultat As String
    aa = Array(6, 7, 8, 9, 10, 12, 14, 15, 16)
    For i = 0 To UBound(aa)
        If pl Is Nothing Then
            Set pl = Rows(aa(i))
        Else
            Set pl = Union(pl, Rows(aa(i)))
        End If
    Next i
    For Each pl2 In pl.Areas
        If pl2.Rows.Count = 1 Then
            resultat = resultat & ", " & pl2.Row
        Else
            resultat = resultat & ", " & pl2.Row & " à " & pl2.Row + pl2.Rows.Count - 1
        End If
    Next pl2
    Debug.Print Mid(resultat, 3)
End Sub
excuse si je suis à coté de la plaque, sinon si ça peut te servir de base de départ...
eric
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
Bonsoir

VB: 
Sub Test()

' Hypothése vous avez dèjà fait la concatenation.
' votre resultat trouvé est déjà stocké dans une variable (exemple pour : 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16)
' Stocké dans la variable ici "xResult"

' Exemple pour la Macro VBA
'Resultat texte de concatenation dans une variable = Votre resultat
xResult= "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16"

' Test Boolean
' Vrais = suite de nombre comme décrit dans votre exemple
' Faux ce n'est pas une suite donc aucune transformation !

' le bout de code ci-dessous :
Dim Test As Boolean
Res = Split(xResult, ",")
    Debt = CDbl(Res(LBound(Res)))
For i = LBound(Res) To UBound(Res)
   If CDbl(Res(i)) = Debt Then
        Test = True
    Else
        Test = False
        ' test faux sortie de boucle
        Exit For
   End If
    Debt = Debt + 1
Next i

' Transformation ou pas en fonction du resultat du test :
If Test = True Then
    ' 1 à 16 (au lieu de 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16)
    xResult= Res(LBound(Res)) & " à " & Res(UBound(Res))
Else
    ' 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16
    xResult= xResult
End If

' Resultat en Message Box
MsgBox xResult
End Sub

Joyeux repas de Noël entre collègues, en espèrent avoir ciblé une partie de la solution.

Laurent
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonsoir.
Je dirais comme ça, si j'ai bien compris :
VB: 
Function CONCATSI(ByVal CriteriaRange As Range, ByVal Condition As Variant, _
   ByVal ConcatenateRange As Range, Optional ByVal Separator As String = ", ") As Variant
Dim TCrit(), TConc(), L&, C&, N&, TR(), M&
TCrit = CriteriaRange.Value: TConc = ConcatenateRange.Value
If UBound(TCrit, 1) <> UBound(TConc, 1) Or UBound(TCrit, 2) <> UBound(TConc, 2) Then
   CONCATSI = CVErr(xlErrRef)
   Exit Function
   End If
ReDim TR(1 To 1)
For L = 1 To UBound(TCrit, 1): For C = 1 To UBound(TCrit, 2)
   If TCrit(L, C) = Condition Then
      N = N + 1: ReDim Preserve TR(1 To N): TR(N) = TConc(L, C): End If: Next C, L
M = 1
For N = 2 To UBound(TR)
   If TR(N) <> TR(N - 1) + 1 Then
      If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
      M = M + 1: TR(M) = TR(N): End If: Next N
If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
ReDim Preserve TR(1 To M)
CONCATSI = Join(TR, Separator)
End Function
À tester plus à fond.
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Allez ! J'y va aussi de ma petite fonction.

Vu son programme pour cette soirée, je crains fort qu'on ne revoit Staple1600 que tard dans la matinée de demain :cool:.
 

Pièces jointes

  • Staple1600- ecritureCompacte- v1.xlsm
    16.1 KB · Affichages: 28
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Me revoilà après les agapes prêt à en découdre avec VBA ;)
Donc pour éclairer la question
01Concat.jpg
Pour résumer, quand la concaténation ne contient pas trop de nombres
(moins 6 ou 7), on laisse la concaténation telle quelle
Par contre si les nombres sont consécutifs, la fonction renvoie
1er nombre à dernier nombre
(comme expliquer précédemment: 1 à 16 ou 3 à 9 etc...
[la benoîte question]
Pour ma gouverne, c'est bien une suite arithmétique de raison 1 quand les chiffres sont consécutifs?
(d'où mes calculs alambiqués dans ma fonction)
[/la benoîte question]
Pour le moment, je n'ai testé que la fonction de Dranreb qui fait presque le job.
Je ne sais pas si les relents de kir breton vont me laisser le loisir de tester ce soir les autre propositions. ;)
 

Pièces jointes

  • donnees.txt
    574 bytes · Affichages: 20
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Une version qui laisse la concaténation brute si elle ne prend pas plus de 15 caractères :
VB: 
Function CONCATSI(ByVal CriteriaRange As Range, ByVal Condition As Variant, _
   ByVal ConcatenateRange As Range, Optional ByVal Separator As String = ", ") As Variant
Dim TCrit(), TConc(), L&, C&, N&, TR(), M&
If TypeOf Condition Is Range Then Condition = Condition.Value
TCrit = CriteriaRange.Value: TConc = ConcatenateRange.Value
If UBound(TCrit, 1) <> UBound(TConc, 1) Or UBound(TCrit, 2) <> UBound(TConc, 2) Then
   CONCATSI = CVErr(xlErrRef)
   Exit Function
   End If
ReDim TR(1 To 1)
For L = 1 To UBound(TCrit, 1): For C = 1 To UBound(TCrit, 2)
   If TCrit(L, C) = Condition Then
      N = N + 1: ReDim Preserve TR(1 To N): TR(N) = TConc(L, C): End If: Next C, L
CONCATSI = Join(TR, Separator)
If Len(CONCATSI) <= 15 Then Exit Function
M = 1
For N = 2 To UBound(TR)
   If TR(N) <> TR(N - 1) + 1 Then
      If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
      M = M + 1: TR(M) = TR(N): End If: Next N
If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
ReDim Preserve TR(1 To M)
CONCATSI = Join(TR, Separator)
End Function
Une version qui prend la plus courte :
VB: 
Function CONCATSI(ByVal CriteriaRange As Range, ByVal Condition As Variant, _
   ByVal ConcatenateRange As Range, Optional ByVal Separator As String = ", ") As Variant
Dim TCrit(), TConc(), L&, C&, N&, TR(), M&, Brut As String
If TypeOf Condition Is Range Then Condition = Condition.Value
TCrit = CriteriaRange.Value: TConc = ConcatenateRange.Value
If UBound(TCrit, 1) <> UBound(TConc, 1) Or UBound(TCrit, 2) <> UBound(TConc, 2) Then
   CONCATSI = CVErr(xlErrRef)
   Exit Function
   End If
ReDim TR(1 To 1)
For L = 1 To UBound(TCrit, 1): For C = 1 To UBound(TCrit, 2)
   If TCrit(L, C) = Condition Then
      N = N + 1: ReDim Preserve TR(1 To N): TR(N) = TConc(L, C): End If: Next C, L
Brut = Join(TR, Separator)
M = 1
For N = 2 To UBound(TR)
   If TR(N) <> TR(N - 1) + 1 Then
      If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
      M = M + 1: TR(M) = TR(N): End If: Next N
If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
ReDim Preserve TR(1 To M)
CONCATSI = Join(TR, Separator)
If Len(Brut) < Len(CONCATSI) Then CONCATSI = Brut
End Function
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Dranreb, je viens juste de voir ta dernière réponse
Entre temps j'avais mixer mon code avec la proposition de Laurent950
VB: 
Function CONCAT_Laurent950_SI(ByVal CriteriaRange As Range, ByVal Condition As Variant, ByVal ConcatenateRange As Range, Optional ByVal Separator As String = ",") As Variant
Dim xResult As String, i, t, X, aa, bb, zz$
Dim Test As Boolean
On Error Resume Next
If CriteriaRange.Count <> ConcatenateRange.Count Then
CONCAT_Laurent950_SI = CVErr(xlErrRef)
Exit Function
End If
For i = 1 To CriteriaRange.Count
If CriteriaRange.Cells(i).Value = Condition Then
xResult = xResult & Separator & ConcatenateRange.Cells(i).Value
End If
Next i
If xResult <> "" Then
Res = Split(xResult, ",")
Debt = CDbl(Res(LBound(Res) + 1))
For i = LBound(Res) + 1 To UBound(Res)
   If CDbl(Res(i)) = Debt Then
        Test = True
    Else
        Test = False
        Exit For
   End If
    Debt = Debt + 1
Next i
If Test = True And Len(xResult) > 8 Then
xResult = Res(LBound(Res) + 1) & " à " & Res(UBound(Res))
Else
 xResult = Mid(xResult, 2, 9 ^ 9)
End If
End If
CONCAT_Laurent950_SI = xResult
End Function
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Au final, j'opte donc pour la fonction de Dranreb (que je remercie)
Merci également à tous les participants du fil.
NB: Est-ce que quelqu'un peut apporter réponse à ma benoîte question du message#6
(Faut vous dire que j'ai vécu une relation difficile avec les mathématiques à partir du collége et après il fut trop tard (à mon grand regret) pour combler les lacunes)
VB: 
Function CONCATESI(ByVal CriteriaRange As Range, ByVal Condition As Variant, _
   ByVal ConcatenateRange As Range, Optional ByVal Separator As String = ",") As Variant
Dim TCrit(), TConc(), L&, C&, N&, TR(), M&
If TypeOf Condition Is Range Then Condition = Condition.Value
TCrit = CriteriaRange.Value: TConc = ConcatenateRange.Value
If UBound(TCrit, 1) <> UBound(TConc, 1) Or UBound(TCrit, 2) <> UBound(TConc, 2) Then
   CONCATESI = CVErr(xlErrRef)
   Exit Function
   End If
ReDim TR(1 To 1)
For L = 1 To UBound(TCrit, 1): For C = 1 To UBound(TCrit, 2)
   If TCrit(L, C) = Condition Then
      N = N + 1: ReDim Preserve TR(1 To N): TR(N) = TConc(L, C): End If: Next C, L
CONCATESI = Join(TR, Separator)
If Len(CONCATESI) <= 15 Then Exit Function
M = 1
For N = 2 To UBound(TR)
   If TR(N) <> TR(N - 1) + 1 Then
      If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
      M = M + 1: TR(M) = TR(N): End If: Next N
If TR(N - 1) <> TR(M) Then TR(M) = TR(M) & " à " & TR(N - 1)
ReDim Preserve TR(1 To M)
CONCATESI = Join(TR, Separator)
End Function

PS: Si jamais, il prend l'envie aux formulistes de trouver une formule qui fasse la même chose, je suis preneur, histoire de varier les plaisirs ;)
Et si jamais, vous pensez qu'on peut faire autrement que Dranreb ou plus court, n'hésitez pas non plus ;)
Là ,c'est plus rapport à la beauté du geste ou pour rester dans le ton de la soirée pour avoir le flacon de l'ivresse ou l'ivresse du flacon à moins que ce ne soit "qu'importe le flacon pourvu qu'on ait l'ivresse" sans option mais explicitement ;)

Sur ce, je crois qu'il est temps d'aller pousser mon roupillon, car demain fini les cotillons, les affaires reprennent.

Bonnes fêtes à tous ;)
 
Dernière édition:
Vote positif 0 Vote négatif
eriiic

eriiic

XLDnaute Barbatruc
Si tu pouvais mettre ce qu'il faut obtenir ou bien un appel avec les paramètres et le résultat

Dans ma proposition par exemple avec (6, 7, 8, 9, 10, 12, 14, 15, 16) j'obtiens "6 à 10, 12, 14 à 16",
et "6 à 16" sans les trous ajoutés.
iznogoud ?

edit : je n'avais pas vu ton image.
J'en déduis que ma proposition était sans doute trop courte pour mériter un test ;-)
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

@eriiiic
J'ai mis un exemple (message#6)
Copie écran plus fichier joint.
Avec les données du fichier texte
La dernière fonction de Dranreb et celle mixant ma fonction avec le code de Laurent950 donnent le bon résultat.

Par exemple avec (6, 7, 8, 9, 10, 12, 14, 15, 16) j'obtiens "6 à 10, 12, 14 à 16"
Cliquez pour agrandir...
Dans cet exemple, on peut laisser tel quel.
Ou effectivement on pourrait opter pour :"6 à 10, 12, 14 à 16"
Je ne serais pas l'utilisateur final de cette fonction, j'en reparle demain à ma collègue et vous redit.

EDITION: Je viens de tester la fonction de Dranreb avec les chiffres cités par @eriiiic
Sa fonction donne déjà ce résultat.
Il est vraiment temps que j'aille me coucher

Merci à tous encore une fois ;)
(par ordre d'apparition : @eriiiic @laurent950 @Dranreb @mapomme )
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
XL 2019 Nom et Prenom sans accent avec MID
Réponses
4
Affichages
178
crocrocro
C
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
534
halecs93
halecs93
patricktoulon
  • Question
XL 2013 crer une liste de nombres aleatoires entre un min et un max avec une fonction VBA méthode particulière
5 6 7
Réponses
94
Affichages
2 K
patricktoulon
patricktoulon
A
  • Résolu(e)
Microsoft 365 Correction du code vba
Réponses
5
Affichages
173
AD95
A
T
  • Question
Microsoft 365 probleme passage paramètre dans une fonction
Réponses
8
Affichages
267
Phil69970
Phil69970
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
233
Claudinedu13
C
patricktoulon
  • Résolu(e)
XL 2013 prise de tête avec une variable static
Réponses
3
Affichages
228
patricktoulon
patricktoulon
Regueiro
  • Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
285
sylvanu
sylvanu
N
  • Résolu(e)
Microsoft 365 Ajouter une condition dans une VBA
Réponses
2
Affichages
194
Nathan027
N
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
352
crocrocro
C

Membres actuellement en ligne

15 membres et 276 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 169
Messages
2 085 909
Membres
103 031
dernier inscrit
Karmeliet69