Microsoft 365 [RESOLU] VBA | Concaténation des adresses avec répétitions si le complément de voie est renseigné.

[ralph45]

Bonjour,

À la base, je dispose d'un fichier de plus de 5 000 lignes où sont référencées en colonnes A, B et C des adresses normées. Avec un script VBA, je désirerai générer en colonne F (exemple) une liste d'adresses qui concatène les données de départ, tout en créant des occurrences si l'indice "complément de voie " est renseigné.

Ainsi, le complément 10/14 RUE DE LA TARTE générera 3 lignes... (voir ci-dessous et le fichier en PJ qui recense d'autres cas de structures identifiées).
Précisions :
- La colonne A est strictement numérique;
- La colonne B est alphanumérique, si renseignée ;
- La colonne C est alphabétique.

En vous remerciant d'avance pour votre contribution, je vous souhaite un bon week-end ensoleillé !

A	B	C
10	/14	RUE DE LA TARTE

F
10 RUE DE LA TARTE
12 RUE DE LA TARTE
14 RUE DE LA TARTE

 

[patricktoulon]

re
bonjour
une petite sub

Sub liste()
    Dim t(), lig&, col, i&, a&, v$
    Feuil1.[e2].Resize(ActiveSheet.UsedRange.Rows.Count, 1).ClearContents
    With Range("Tableau1").ListObject.DataBodyRange
        For lig = 1 To .Rows.Count
            a = a + 1: ReDim Preserve t(1 To a)
            t(a) = .Cells(lig, 1) & " " & .Cells(lig, 3)
            If .Cells(lig, 2) <> "" Then
              v = .Cells(lig, 2): If Left(.Cells(lig, 2), 1) <> "/" Then v = "/" & .Cells(lig, 2)
               col = Split(v, "/")
                For i = 1 To UBound(col)
                    a = a + 1: ReDim Preserve t(1 To a)
                    t(a) = col(i) & " " & .Cells(lig, 3)
                Next
            End If
        Next
    End With
    Feuil1.[e2].Resize(UBound(t)) = Application.Transpose(t)
End Sub

 

[patty58]

Bonjour Ralph, bonjour Patrick
@patrick
Tu travailles mieux et plus vite que moi.
Par contre , si j'ai bien compris sa demande, dans les cas de la ligne 5 :
56, puis /66, j'ai cru comprendre qu'il souhaitait avoir 56,58,60, et ainsi jusqu'à 66 inclus
Bon après-midi

 

[patricktoulon]

re
j'avais oublié je joins le fichier car j'ai transformé la plage source en TS

 

[ralph45]

Bonjour Ralph, bonjour Patrick
@patrick
Tu travailles mieux et plus vite que moi.
Par contre , si j'ai bien compris sa demande, dans les cas de la ligne 5 :
56, puis /66, j'ai cru comprendre qu'il souhaitait avoir 56,58,60, et ainsi jusqu'à 66 inclus
Bon après-midi

@patty58

56, puis /66, j'ai cru comprendre qu'il souhaitait avoir 56,58,60, et ainsi jusqu'à 66 inclus

C'est exactement l'objet de ma demande ! ;-)

Je regarde ce qu'a fait Patrick et vous tiens au courant...

 

[ralph45]

@patricktoulon,

Ton script fonctionne à merveille... à 99%
Comme l'a remarqué @patty58, dans le cas où l'adresse est :

56/66 RUE DE LA PÉTANQUE

... il faudrait générer 6 lignes :

56 RUE DE LA PÉTANQUE
58 RUE DE LA PÉTANQUE
60 RUE DE LA PÉTANQUE
62 RUE DE LA PÉTANQUE
64 RUE DE LA PÉTANQUE
66 RUE DE LA PÉTANQUE

Encore merci !

 

[patty58]

Bonjour tous deux,
vois avec la macro de Patrick modifiée

[CODE=vb]Sub liste_Patty()

    Dim t(), lig&, col, i&, a&, n&, v$

    Feuil1.[e2].Resize(ActiveSheet.UsedRange.Rows.Count, 1).ClearContents

    With Range("Tableau1").ListObject.DataBodyRange

        For lig = 1 To .Rows.Count

            a = a + 1: ReDim Preserve t(1 To a)

            t(a) = .Cells(lig, 1) & " " & .Cells(lig, 3)

            If .Cells(lig, 2) <> "" Then

              v = .Cells(lig, 2): If Left(.Cells(lig, 2), 1) <> "/" Then v = "/" & .Cells(lig, 2)

               col = Split(v, "/")

               If UBound(col) > 1 Then

                    For i = 1 To UBound(col)

                        a = a + 1: ReDim Preserve t(1 To a)

                        t(a) = col(i) & " " & .Cells(lig, 3)

                    Next

               Else

                    If (col(1) Like "*" & .Cells(lig, 1) & "*") Or (col(1) = .Cells(lig, 1) + 2) Then

                        a = a + 1: ReDim Preserve t(1 To a)

                        t(a) = col(1) & " " & .Cells(lig, 3)

                    Else

                        NbNum = (col(1) - .Cells(lig, 1)) / 2

                        Valn = .Cells(lig, 1).Value

                        For n = 1 To NbNum

                            a = a + 1: ReDim Preserve t(1 To a)

                            Valn = Valn + 2

                            t(a) = Valn & " " & .Cells(lig, 3)

                           

                        Next

                    End If

               End If

            End If

        Next

    End With

    Feuil1.[e2].Resize(UBound(t)) = Application.Transpose(t)

End Sub

[/CODE]

Pardon @patrick d'avoir saboté ton travail, ça marche , mais tu aurais certainement fait plus élégant !!

 

[patricktoulon]

re
Bonjour @patty58
y a pas de soucis
donc si j'ai bien compris
si il y a
56/60
ou 56/57/60

il faut faire 56,57,58,59,60
c'est bien ça

si c'est ça alors c'est simple
tu reprends mon code
et après
col = Split(v, "/")
tu fait debut= col(0)
fin = col(ubound(col))
for i= debut to fin
blablabla comme tu l'a fait pure le reste

tu t'en occupe patty58 ?

 

[patty58]

@patrick
J'ai envoyé la macro modifiée qui semble marcher , donc pour l'instant , on attend de voir si cela convient

 

[DJunqueira]

Bonjour tous

Avec formule 365.

=LET(a;A2:A6;b;B2:B6;c;C2:C6;f;FILTRE.XML("<F><d>"&SUBSTITUE(b;"/";"</d><d>")&"</d></F>";"//d[last()]");g;ESTTEXTE(f)+1+(SIERREUR(--f;a)-a)/2;
FRACTIONNER.TEXTE(CONCAT(MAP(a;b;f;g;LAMBDA(w;x;y;z;JOINDRE.TEXTE(";";1;SI(ESTTEXTE(y);w&";"&x;SEQUENCE(z;;w;2))&";"))));;";";1)&" "&FRACTIONNER.TEXTE(CONCAT(REPT(c&"\";g));;"\";1))

 

[ralph45]

Bonjour et merci pour votre aide !

Le code VBA remanié par @patty58 fonctionne à merveille !
Bravo à @DJunqueira pour sa formule365 !

Merci et encore bon week-end !

 

[DJunqueira]

Merci beaucoup ralph45 et bonne chance avec votre feuille de calcul.

 

[patricktoulon]

re
pour le vba je l'aurais ecrit comme ça

Sub liste2()
    Dim t(), lig&, col, i&, a&, v$, Debut, Fin
    Feuil1.[e2].Resize(ActiveSheet.UsedRange.Rows.Count, 1).ClearContents
    With Range("Tableau1").ListObject.DataBodyRange
        For lig = 1 To .Rows.Count
            v = .Cells(lig, 1) & "/" & .Cells(lig, 2): col = Split(v, "/")
            Debut = col(0): Fin = col(UBound(col))
            a = a + 1: ReDim Preserve t(1 To a): t(a) = col(0) & " " & .Cells(lig, 3)
            If Not IsNumeric(Fin) Then
                If Fin <> "" Then a = a + 1: ReDim Preserve t(1 To a): t(a) = Fin & " " & .Cells(lig, 3)
            Else
                For i = Debut + 2 To Fin Step 2
                    a = a + 1: ReDim Preserve t(1 To a): t(a) = i & " " & .Cells(lig, 3)
                Next
            End If
        Next
    End With
    Feuil1.[e2].Resize(UBound(t)) = Application.Transpose(t)
End Sub

 

[patty58]

@patrick
On voit la différence entre une "bidouilleuse" en vba et un pro.
Pour moi, quand cela marche, je suis déjà contente.
Désolée d'avoir mal corrigé ton code, pas de rancune ??
Bonne fin de journée à tous

 

[patricktoulon]

re
je n 'ai aucune rancune
le partage nous permet d’évoluer
et pour finir je te propose de regarder ça
on transforme le tout en fonction
que l'on appellera en formule ( à valider en matricielle pour les version inférieures à 2021 et 365

allez c'est parti

Function ConcatAdressList(r As Range)
    Dim t$(), lig&, col, i&, a&, v$, Debut, Fin
        ReDim Preserve t(1 To Application.Caller.Rows.Count * 10)
    With r
        For lig = 1 To .Rows.Count
            v = .Cells(lig, 1) & "/" & .Cells(lig, 2): col = Split(v, "/")
            Debut = col(0): Fin = col(UBound(col))
            a = a + 1:  t(a) = col(0) & " " & .Cells(lig, 3)
            If Not IsNumeric(Fin) Then
                If Fin <> "" Then a = a + 1:  t(a) = Fin & " " & .Cells(lig, 3)
            Else
                For i = Debut + 2 To Fin Step 2
                    a = a + 1:: t(a) = i & " " & .Cells(lig, 3)
                Next
            End If
        Next
    End With
     DoEvents
   ConcatAdressList = Application.Transpose(t)
End Function

démonstration