[VBA UDF] Concaténation particulière

[Staple1600]

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.

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

 

[eriiic]

Bah oui. Mais elle est trop courte pour paraitre sérieuse ;-)

 

[Dranreb]

Y a ptê't même pas à explorer les Areas: Quelques Replace sur l'adresse de la plage obtenue devraient suffire, non ?

 

[mapomme]

@eriiiic

Je plussois à ce qu'a dit Dranreb : Le coup de l'union est sioux . ça fonctionne bien si les valeurs en entrée sont uniques. Ce qui semble être le cas des données d'entrée de Staple1600.

 

[eriiic]

Bonjour,

aussi oui, on peut remplacer ":" par " à ", supprimer les $ et encore qq lignes de gagnées

ça fonctionne bien si les valeurs en entrée sont uniques.

si doublons ils sont fusionnés.
Mais c'est un avantage. J'avais trouvé cette technique pour fusionner des plages de dates qui se chevauchent et avoir toutes les unions, c'est redoutable comparé à la prise de tête avant ;-)
eric

 

[Staple1600]

Bonsoir le fil, le forum

@eriiiic
C'est surement redoutable, mais je n'arrive pas à transformer ta macro en fonction
(J'ai testé ta macro mais pas à jeun (voir mon premier message )
Il y a surement une évidence mais je ne le vois actuellement pas.
Tu peux éclairer ma lanterne, stp?

Précisions (pour la fonction)
Lors de mes tests de la fonction de Dranreb (message#7), le résultat peut donner
3 à 4, 8 à 16 par exemple
donc ce cas on devrait avoir 3,4, 8 à 16
(Disons que jusqu'à 3 chiffres consécutifs , on laisse tel quel: 3,4,5 au lieu de 3 à 5)

 

[eriiic]

Ah, ça m'étonne de toi. Il n'y a aucun piège

Function concat(s As String) As String
    Const nb As Long = 4 ' nombre de valeurs à partir duquel compacter avec " à "
    Dim aa, i As Long, j As Long, pl As Range, pl2 As Range
    aa = Split(Application.Trim(s), ",")
    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 >= nb Then
            concat = concat & ", " & Replace(pl2.Address(0, 0), ":", " à ")
        Else
            aa = Split(pl2.Address(0, 0), ":")
            For j = aa(0) To aa(1)
                concat = concat & ", " & j
            Next j
        End If
    Next pl2
    concat = Mid(concat, 3)
End Function

edit : changé paramètres de .Address pour éviter la suppression des $
eric

 

[Staple1600]

Re

@eriiic
La fonction doit prendre des plages en paramètres, pas des string.
La concaténation se fait selon une condition entre deux plages
Comme dans ma copie d'écran du message#6
D’où ma difficulté à transformer ta macro en fonction

Ci-dessous une autre copie (avec utilisation de la fonction de Dranreb)
Formule en C2 qui renvoie: 1,4,8

 

[Dranreb]

Bonsoir.
On repère moins facilement les trous quand il n'y a que des suites de petites séries, mais bon…

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
N = 1
Do: M = M + 1: TR(M) = TR(N)
   Do: N = N + 1: If N > UBound(TR) Then Exit Do
      Loop Until TR(N) <> TR(N - 1) + 1
   If TR(N - 1) - TR(M) < 3 Then
      Do: M = M + 1: TR(M) = TR(M - 1) + 1: Loop Until TR(M) = TR(N - 1)
   Else: TR(M) = TR(M) & " à " & TR(N - 1): End If
   Loop Until N > UBound(TR)
ReDim Preserve TR(1 To M)
CONCATESI = Join(TR, Separator)
End Function

 

[Staple1600]

Bonsoir Dranreb

Ta dernière fonction renvoie #VALEUR! sauf si la cellule en colonne A contient juste 1
J'essaie de trouver pourquoi.

 

[Dranreb]

J'avais repéré une autre manifestation d'erreur mais peut être due à la même: Remplacer:
Do: M = M + 1: TR(M) = TR(M - 1) + 1: Loop Until TR(M) = TR(N - 1) par:
Do While TR(M) < TR(N - 1): M = M + 1: TR(M) = TR(M - 1) + 1: Loop
C'est la 5ième ligne en remontant depuis la End Function

 

[Staple1600]

Re

Ok je fais le remplacement EDITION: La correction donne bien l'affichage souhaité.

Je mets une autre copie écran pour compléter les explications

NB: Je n'ai toujours pas trouvé comment employé la syntaxe d'eriiic dans le cas présent.
PS: La fonction dans la colonne C est la fonction de Dranreb (version message #7)

 

[Dranreb]

Avec la fonction corrigée, En C2, propagé sur 13 lignes :

=CONCATESI($B$2:$B$14;$B2;$A$2:$A$14)

j'ai "1,2,5,6,7,11 à 16" pour la plupart des lignes sauf C3 et C5 où c'est 1

L'idée d'eriiiic si j'ai bien compris c'est :

Function IdéeEriiiic(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&, Rng As Range
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
   IdéeEriiiic = 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
Set Rng = Cells(TR(1), 1): For N = 2 To UBound(TR): Set Rng = Union(Rng, Cells(TR(N), 1)): Next N
IdéeEriiiic = Replace(Replace(Rng.Address, "$A$", ""), ":", " à ")
End Function

En E2, propagé sur 13 lignes :

=IdéeEriiiic($B$2:$B$14;$B2;$A$2:$A$14)

donne "1 à 2,5 à 7,11 à 16" pour la plupart des lignes.
S'il faut retraiter les suites trop brèves, ça perd un peu de son intérêt.

 

[eriiic]

La fonction doit prendre des plages en paramètres, pas des string.
La concaténation se fait selon une condition entre deux plages
Comme dans ma copie d'écran du message#6

C'eut été mieux au #1, je t'avais dit que tu m'avais largué avec les conditions et ton code.
Bon ok, c'est pécher que de laisser fondre les glaçons, tu étais pris par le temps.

C'est du pareil au même, juste à changer un peu le début :

Function concat(CriteriaRange As Range, Condition As Variant, ConcatenateRange As Range, Optional Separator As String = ", ") As String
    Const nb   As Long = 4    ' nombre de valeurs à partir duquel compacter avec " à "
    Dim i As Long, j As Long, pl As Range, pl2 As Range, tmp
    Dim critR, cond, ConcatR
    critR = CriteriaRange.Value: cond = Condition.Value: ConcatR = ConcatenateRange.Value
    For i = 1 To UBound(critR)
        If critR(i, 1) = cond Then
            If pl Is Nothing Then
                Set pl = Rows(ConcatR(i, 1))
            Else
                Set pl = Union(pl, Rows(ConcatR(i, 1)))
            End If
        End If
    Next i
    For Each pl2 In pl.Areas
        If pl2.Rows.Count >= nb Then
            concat = concat & Separator & Replace(pl2.Address(0, 0), ":", " à ")
        Else
            tmp = Split(pl2.Address(0, 0), ":")
            For j = tmp(0) To tmp(1)
                concat = concat & Separator & j
            Next j
        End If
    Next pl2
    concat = Mid(concat, 3)
End Function

Tu as une constante au début pour le nombre de consécutifs à regrouper.
eric

edit :

S'il faut retraiter les suites trop brèves, ça perd un peu de son intérêt.

non pas retraiter, mais 2 traitement différents

 

[Staple1600]

Re

Merci Dranreb pour la transcription de la macro d'eriiiic en fonction.
Le choix (qui n'est pas le mien) de l'affichage est bien celui indiqué en message#26
(colonne D)
Si les nombres consécutifs sont <=3 , on n'utilise pas la syntaxe 1 à N.

 

[Dranreb]

non pas retraiter, mais 2 traitement différents

Oui, je voulais dire qu'on ne pouvait plus éviter tout retraitement de Replace(Replace(Rng.Address, "$A$", ""), ":", " à ") qui en aurait fait tout l'intérêt.
Mais alors autant prendre mon algorithme, je crois.

l'affichage est bien celui indiqué en message#26
(colonne D)

Sans l'erreur, je suppose, du 10 au lieu du 11 ?