XL 2019 Excel différentes feuilles

[Tatiana22]

Bonsoir,

Je souhaiterai avoir sur la feuille 1 :
1ere colonne : commune de contact
2eme colonne : numéro de téléphone
3eme colonne : Nom


sur la 2eme feuille nommée 42110, je souhaiterai uniquement la partie du tableau de la feuille 1 avec la commune de contact correspondant à la page.
donc si 1er colonne de la feuille 1 = 42110 alors recopier les colonnes 2 et 3 sur la feuille 2

sur la 3eme feuille nommé 43560, idem

etc
J'espère que je suis claire :- S merci par avance de votre aide

 

[Tatiana22]

 

[Chris401]

Bonsoir et bienvenue
Peux-tu expliquer pourquoi créer des feuilles alors qu'il te suffit de filtrer la colonne B pour avoir ce que tu désires ?

Merci de joindre un fichier à la place d'une image

 

[Tatiana22]

ce fichier sera partagé par une vingtaine de personne mais toutes ne pourrons pas modifier le contenu de tous les onglets.

 

[Chris401]

Donc envoie un fichier STP - Tu auras plus de chance d'obtenir des réponses.

 

[cp4]

Bonjour Chris401, Tatiana22,

à tester.

Option Explicit
Dim cle, MaFeuil As Worksheet
Sub dispatcher()
    Dim ws As Worksheet, cel As Range, Rng As Range, d As Object
    Set MaFeuil = Sheets("Nov 2021")
    Set d = CreateObject("scripting.dictionary") 'dictionnaire

    With MaFeuil
        If .FilterMode = True Then .ShowAllData

        Set Rng = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
        For Each cel In Rng
            d(cel.Value) = "" 'données sans doublon
        Next cel

        If d.Count > 0 Then 's'il y a des données
            For Each cle In d.keys 'boucle
                If Contains(Sheets, CStr(cle)) Then 'si feuille existe
                    Sheets(CStr(cle)).Cells.Clear 'on efface tout
                    FiltrerCopierColler 'appel procédure
                Else
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = cle 'sinon on ajoute feuille+nom
                    FiltrerCopierColler 'appel procédure
                End If
            Next cle
        End If

    End With
    Set MaFeuil = Nothing: Set d = Nothing
End Sub

Sub FiltrerCopierColler()
    Dim maplage As Range
    Application.ScreenUpdating = False
    With MaFeuil
        .Activate
        If .FilterMode = True Then .ShowAllData 'si filtre afficher tout
        .Range("B1").AutoFilter Field:=1, Criteria1:=cle 'filtrage
        Set maplage = .Range("B1:" & .Range("C65536").End(xlUp).Address).SpecialCells(xlCellTypeVisible) ' affecte lignes visibles à variable
        maplage.Copy Sheets(CStr(cle)).Range("A1") 'copie/colle
        Sheets(CStr(cle)).Range("A:B").Columns.AutoFit 'ajuste largeur colonne destination
        If .FilterMode = True Then .ShowAllData 'si filtre afficher tout
    End With
    Application.ScreenUpdating = True
    Set maplage = Nothing
End Sub

Public Function Contains(objCollection As Object, strName As String) As Boolean
'Cette fonction peut être utilisée avec toute collection comme objet ( Shapes, Range, Names, Workbooks, etc.).
'Pour vérifier l'existence d'une feuille, utilisez If Contains(Sheets, "SheetName") ...
    Dim o As Object
    On Error Resume Next
    Set o = objCollection(strName)
    Contains = (Err.Number = 0)
    Err.Clear
 End Function

A+

 

[JHA]

Bonjour à tous,

Une solution avec un filtre avancé

JHA

 

[Chris401]

Bonjour à tous
Avec formules

 

[Tatiana22]

Merci bcp !!!!