XL 2019 Excel différentes feuilles

Tatiana22

XLDnaute Nouveau
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
 

Pièces jointes

  • mobiles.xlsx
    12.7 KB · Affichages: 5
Dernière édition:

Tatiana22

XLDnaute Nouveau
1637089228793.png
 

cp4

XLDnaute Accro
Bonjour Chris401;), Tatiana22:),

à tester.
VB:
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+
 

Discussions similaires

Statistiques des forums

Discussions
298 770
Messages
1 971 597
Membres
203 410
dernier inscrit
nicodag