Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

[VBA UDF] Concaténation particulière

Créer une discussion

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 !

S'inscrire

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

Me revoilà après les agapes prêt à en découdre avec VBA 😉
Donc pour éclairer la question

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

Dernière édition:
Vote positif 0 Vote négatif
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
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
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
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
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
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

Discussions similaires

L
  • Question Question
Microsoft 365 Erreur automation 440 sur code VBA
Réponses
1
Affichages
137
job75
F
  • Question Question
Microsoft 365 Problème mémoire insuffisante
Réponses
5
Affichages
302
TooFatBoy
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
373
patricktoulon
  • Question Question
XL 2016 XLS - Comment déterminer les zones présentent au niveau d'une cellule ?
Réponses
2
Affichages
242
Lu76Fer
  • Question Question
Autres la fonction similaire
Réponses
11
Affichages
650
patricktoulon
  • Résolu(e)
Microsoft 365 Problème de formatage de dates au format EUR
Réponses
2
Affichages
166
R1-
EXCEL :: Les Tableaux Structurés :: Une classe VBA - V1.05 - Evolutions majeures exports CSV, XML, XML UTF-8, JSON, HTML, PDF, JPG, JPEG, BMP, EXCEL
Réponses
10
Affichages
462
oguruma
  • Résolu(e)
Autres que penses vous de ce mini test benchmark(timer plus precis)
Réponses
6
Affichages
933
patricktoulon
  • Question 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
4 K
patricktoulon
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
1 K
halecs93
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
677
AtTheOne
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
645
Claudinedu13
C
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
  • Résolu(e)
XL 2013 prise de tête avec une variable static
Réponses
3
Affichages
431
patricktoulon
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
386
crocrocro
C
N
  • Résolu(e)
Microsoft 365 Ajouter une condition dans une VBA
Réponses
2
Affichages
420
Nathan027
N
N
  • Question Question
XL 2019 Mettre en gras éléments du graphique avec macro
Réponses
4
Affichages
775
Nasseuz
N
Génération de QR Codes
Réponses
5
Affichages
1 K
mromain
B
  • Résolu(e)
Microsoft 365 affecter des valeurs dans un tableau de noms de variable
Réponses
4
Affichages
853
bérylion
B
G
  • Question Question
Microsoft 365 Export données d'une listview
Réponses
5
Affichages
570
GClaire
G
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…