Microsoft 365 Découper et insérer

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