creer des tableaux dans d'autres feuilles à partir d'un tableau

[Felicite1976]

Bonjour tout le monde
J'ai un tableau(voir pièce jointe) et je veux à partir de ce tableau créer d'autres tableaux dans les feuilles 2, 3 , 4 et 5 en utilisant une condition sur l’unité administrative.
La condition portera sur l'unité administrative par exemple dans la feuille2 je transfère l'ensemble des informations qui ont pour unite administrative 41822 sauf la colonne description et je fais pareille pour les autres unité administrative daans les autres feuilles
J'ai utilisé la fonction rechercheV et voudrais avoir une autre solution plus optimale

 

[vgendron]

Hello

une solution en PJ

 

[Hieu]

Salut, une idée
valeur en bleue (donnee en dur) à modifier
Slt vgendron !

 

[klin89]

Bonjour le fil,

Une solution vba :

Option Explicit
Sub test()
Dim a, w(), x(), e, i As Long, j As Long, n As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        a = Sheets("Feuil1").Range("c3").CurrentRegion.Value
        n = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: ReDim w(1 To 2)
                ReDim x(1 To 7, 1 To 2)
                w(1) = n
                For j = 1 To 6
                    x(j, 1) = a(1, j)
                Next
                x(7, 1) = a(1, 8)
            Else
                w = .Item(a(i, 1))
                x = w(2)
                ReDim Preserve x(1 To 7, 1 To UBound(x, 2) + 1)
            End If
            For j = 1 To 6
                x(j, UBound(x, 2)) = a(i, j)
            Next
            x(7, UBound(x, 2)) = a(i, 8)
            w(2) = x
            .Item(a(i, 1)) = w
        Next
        For Each e In .keys
            If Not IsSheetExists("Feuil" & .Item(e)(1)) Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Feuil" & .Item(e)(1)
            End If
            w = .Item(e)(2)
            With Sheets("Feuil" & .Item(e)(1)).Cells(1)
                .CurrentRegion.Clear
                With .Resize(UBound(w, 2), UBound(w, 1))
                    .Value = Application.Transpose(w)
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .HorizontalAlignment = xlCenter
                        .Interior.ColorIndex = 40
                        .Font.Size = 11
                    End With
                    '.Columns.AutoFit
                    .Columns.ColumnWidth = 19
                    .Rows.RowHeight = 18
                End With
            End With
        Next
    End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
 
Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

klin89

 

[Felicite1976]

Merci vgendron, Hieu et Klin89 de votre réponse
je suis tres satisfait de vos solutions
Merci encore