Microsoft 365 Découper et insérer

[natorp]

Bonjour à toutes et tous

Je vais essayer d'être clair
En colonne A il y a des Unité Foncières (UF), en colonne B les parcelles cadastrales associées
J'aimerai faire en sorte qu'il y ait une ligne par parcelle pour une même UF
Je vous joins un fichier d'exemple avec la base en feuil1 et le résultat attendu en feuil2

Merci beaucoup pour votre aide, cordialement, Gérard

 

[Eric KERGRESSE]

Bonjour,

Si VBA est permis, à mettre dans un module standard :

Sub Decoupe()

Dim TabCible As ListObject
Dim LigneCible As ListRow
Dim I As Long, J As Long, DerniereLigne As Long
Dim AireUf As Range, AireParcelles As Range
Dim TabParcelles As Variant
Dim ShCible As Worksheet


    With Sheets("Feuil1")
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireUf = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
    End With
    
    Set ShCible = Sheets.Add(After:=ActiveSheet)
    
    With ShCible
        .Range("A1:B1") = Array("UF", "PARCELLES")
        .ListObjects.Add(xlSrcRange, Range("$A$1:$B$1"), , xlYes).Name = "Tableau" & Sheets.Count
        Set TabCible = .ListObjects(1)
    End With
    
    For I = 1 To AireUf.Count
        TabParcelles = Split(AireUf(I).Offset(0, 1), " ")
        For J = LBound(TabParcelles) To UBound(TabParcelles)
            Set LigneCible = TabCible.ListRows.Add
            With LigneCible
                 .Range(1, 1) = AireUf(I)
                 .Range(1, 2) = TabParcelles(J)
            End With
            Set LigneCible = Nothing
        Next J
    Next I
    
    With TabCible
         .Sort.SortFields.Clear
         .Sort.SortFields.Add2 Key:=TabCible.ListColumns(1).DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         .Sort.SortFields.Add2 Key:=TabCible.ListColumns(2).DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
     Set AireUf = Nothing: Set ShCible = Nothing: Set TabCible = Nothing

End Sub

 

[natorp]

Merci Eric
C'est parfait
Bonne journée, Gérard

 

[mapomme]

Bonjour à tous,
Un autre code sous forme de fonction personnalisée qui permet avec les versions récentes d'Excel d'employer cette fonction dans une feuille de calcul (et bien évidemment dans un code VBA).
Voir sur la feuille "Feuil2" juste dans la cellule A1 l'utiliation de fonction Deplier :
=deplier(Feuil1!A1:B6)

Le code de la fonction dans module1 :

Function Deplier(x As Range)
Dim t, i&, n&, s, m&, q&
   t = x.Resize(, 2).Value
   For i = 1 To UBound(t): n = n + UBound(Split(t(i, 2))) + 1: Next
   ReDim r(1 To n, 1 To 2)
   For i = 1 To UBound(t)
      If Trim(t(i, 1)) <> "" And Trim(t(i, 2)) <> "" Then
         s = Split(t(i, 2))
         For m = 0 To UBound(s): q = q + 1: r(q, 1) = t(i, 1): r(q, 2) = s(m): Next
      End If
   Next i
   Deplier = r
End Function

 

[job75]

Bonjour à tous,

Une solution très simple avec ce code dans Feuil2 :

Private Sub Worksheet_Activate()
Dim tablo, resu(), i&, x$, s, j%, n&
tablo = Feuil1.[A1].CurrentRegion.Resize(, 2)
ReDim resu(1 To Rows.Count, 1 To 2)
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(tablo(i, 2))
    For j = 0 To UBound(s)
        n = n + 1
        resu(n, 1) = x
        resu(n, 2) = s(j)
Next j, i
'---restitution---
With [A1]
    If n Then .Resize(n, 2) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

La macro se déclenche quand on active la feuille.

Sur de grands tableaux elle est très rapide car elle utilise des tableaux VBA.

A+

 

[natorp]

Vous êtes géniaux.... merci de nous permettre d'apprendre en permanence

Cordialement, Gérard

 

[job75]

Pour tester j'ai recopié le tableau A2:B6 sur 100 000 lignes.

La macro du post #5 s'exécute en 1 seconde.

J'ai essayé avec la macro du post #2 mais j'ai arrêté au bout de 5 minutes.