Problème de recopie à partir d'un recap

Bonjour,

j'aimerai une recopie à partir de la feuille Recap vers les feuilles concernées (MEDECINE, CHIRURGIE). La problématique c'est qui faut faire la distinction entre AS et IDE.

Si pas possible faire un tableau regroupant les 2 catégories AS et IDE et mettre un filtre (besoin de vos conseils précieux)

Merci par avance

Belle journée

Bonjour

Un essai à tester. Te convient-il ?

Bye !

bonjour GMB,

c'est vraiment génial. Mais j'ai voulu rajouter des feuilles et comme je suis novice ça fonctionne plus. J'aimerai savoir s'il serait possible de rajouter une feuille destinée à la médecine du travail. l'idée c'est de rajouter une case dans le recap avec oui et non medecine travail si je coche oui le tableau se rempli (nom prenom date de naissance et telephone)

Merci par avance pour votre aide

bonne journée

Bonjour

Nouvelle version.

Option Explicit

Dim f As Worksheet, fa As Worksheet, fm As Worksheet, fc As Worksheet
Dim dico As Object, col, k
Dim tabloA, tabloM1(), tabloM2(), tabloC1(), tabloC2()
Dim c&, iA&, iM1&, iM2&, iC1&, iC2&, j&, n&

Sub Ventiler()

    Application.ScreenUpdating = False
    Set fa = ActiveSheet
    tabloA = Sheets("RECAP").Range("A3").CurrentRegion
    Set fm = Sheets("Modèle")
    Set dico = CreateObject("Scripting.Dictionary")

    fm.Visible = True
    For iA = 2 To UBound(tabloA, 1)
        If dico.exists(tabloA(iA, 1)) Then
            fm.Cells.Copy Sheets(tabloA(iA, 1)).Range("A1") 'Si le nom de la feuille existe, on la réinitialise
        Else
            'le nom de feuille n'esiste pas dans le dico mais elle existe peut-être dans le fichier
            On Error Resume Next
            Set f = Sheets(tabloA(iA, 1))
            If Err.Number <> 0 Then
                fm.Copy after:=Sheets("RECAP")  'La feuille n'esiste pas, on la crée
                ActiveSheet.Name = tabloA(iA, 1)
            Else
                fm.Cells.Copy f.Range("A1")
            End If
            dico(tabloA(iA, 1)) = ""
        End If
    Next iA
    k = dico.keys
    col = Array(2, 3, 4, 6, 7, 8, 9, 10, 11, 12)

    For n = 0 To dico.Count - 1
        ReDim tabloM1(1 To UBound(tabloA, 1), 1 To UBound(tabloA, 2))
        tabloM2 = tabloM1
        iM1 = 0: iM2 = 0
        For iA = 2 To UBound(tabloA, 1)
            If tabloA(iA, 1) = k(n) And tabloA(iA, 6) = "AS" Then
                For j = 0 To 9
                    If j <> 2 Then
                        tabloM1(iM1 + 1, j + 1) = tabloA(iA, col(j))
                    Else
                        tabloM1(iM1 + 1, 3) = tabloA(iA, 4) & " " & tabloA(iA, 5)
                    End If
                Next j
                iM1 = iM1 + 1

            ElseIf tabloA(iA, 1) = k(n) And tabloA(iA, 6) = "IDE" Then
                For j = 0 To 9
                    If j <> 2 Then
                        tabloM2(iM2 + 1, j + 1) = tabloA(iA, col(j))
                    Else
                        tabloM2(iM2 + 1, 3) = tabloA(iA, 4) & " " & tabloA(iA, 5)
                    End If
                Next j
                iM2 = iM2 + 1
            End If
        Next iA

        If iM1 > 1 Then  'on doit décaler le tableau IDE
            Sheets(k(n)).Range("A8:J" & 6 + iM1).Insert shift:=xlDown
        End If
        Sheets(k(n)).Range("A7").Resize(iM1, 10) = tabloM1
        Sheets(k(n)).Range("A7:J7").Copy
        Sheets(k(n)).Range("A7:J" & 6 + iM1).PasteSpecial xlPasteFormats

        Sheets(k(n)).Range("A" & 12 + iM1).Resize(iM2, 10) = tabloM2
        Sheets(k(n)).Range("A7:J7").Copy
        Sheets(k(n)).Range("A" & 12 + iM1 & ":J" & 11 + iM1 + iM2).PasteSpecial xlPasteFormats
    Next n

    Sheets("Modèle").Visible = False
    Application.CutCopyMode = False
    fa.Activate
    MsgBox "Travail terminé !"

End Sub

Bye !

Bonjour,

super un trés trés grand merci

Bonne journée

Cordialement