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

ralph45 · 17 Février 2024

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 · 17 Février 2024

re
bonjour
une petite sub

VB:

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 · 17 Février 2024

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 · 17 Février 2024

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

ralph45 · 17 Février 2024

patty58 à dit:
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 · 17 Février 2024

@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 · 17 Février 2024

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

VB:

[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 · 17 Février 2024

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 · 17 Février 2024

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

DJunqueira · 17 Février 2024

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 · 18 Février 2024

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 · 18 Février 2024

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

patricktoulon · 18 Février 2024

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

VB:

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 · 18 Février 2024

@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 · 18 Février 2024

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

VB:

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

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

ralph45

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patty58

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Pièces jointes

ralph45

XLDnaute Impliqué

ralph45

XLDnaute Impliqué

patty58

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

patty58

XLDnaute Occasionnel

DJunqueira

XLDnaute Occasionnel

Pièces jointes

ralph45

XLDnaute Impliqué

DJunqueira

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patty58

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Discussions similaires