Filtrage matrice

Bonjour,

Je dispose de plusieurs classeurs qui sont structurés de cette manière:

En Feuil1 une matrice avec en colonne A et ligne 1 le nom des individus.

En Feuil2 une liste d'individus en colonne A (cette liste varie d'un classeur à l'autre).

Je voudrais qu'en fonction de la liste, je puisse obtenir une nouvelle matrice uniquement avec les individus de la liste en Feuil2 (j'ai mis le résultat en Feuil3).

Merci d'avance

Bonjour,

proposition de solution

Sub test()
    Set ws1 = Sheets("feuil1")
    Set ws2 = Sheets("feuil2")
    Set ws3 = Sheets("feuil3")
    ws3.Cells.ClearContents
    ws1.Rows(1).Copy ws3.Cells(1, 1)
    i = 1
    l = 1
    While ws2.Cells(i, 1) <> ""
        Set re = ws1.Range("A:A").Find(ws2.Cells(i, 1), lookat:=xlWhole)
        l = l + 1
        If re Is Nothing Then
            ws3.Cells(l, 1) = ws.Cells(i, 1)
            ws3.Cells(l, 2) = "non trouvé dans " & ws1.Name
        Else
            re.EntireRow.Copy ws3.Cells(l, 1)
        End If
        i = i + 1
    Wend
End Sub

Testé et approuvé, comme toujours parfai, on peut vraiment compter sur vous.

Merci

Rebonjour,

En fait, il y a un petit problème, cela filtre bien les individus au niveau des lignes, mais pas des colonnes

Basosa a écrit :

Rebonjour,

En fait, il y a un petit problème, cela filtre bien les individus au niveau des lignes, mais pas des colonnes

oups , je n'avais pas remarqué cette subtilité.

voici une solution, j'ai fait quelques tris en espérant que cela ne gêne pas

Sub test()
    Set ws1 = Sheets("feuil1")
    dl1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    dc1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    Set ws2 = Sheets("feuil2")
    dl2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    ws2.Range(ws2.Cells(1, 1), ws2.Cells(dl2, 1)).Sort key1:=ws2.Range("A1"), order1:=xlAscending, Header:=xlNo
    ws1.Range(ws1.Cells(1, 2), ws1.Cells(dl1, dc1)).Sort key1:=ws1.Range("A1"), order1:=xlAscending, Orientation:=xlLeftToRight, Header:=xlYes
    Set ws3 = Sheets("feuil3")
    ws3.Cells.ClearContents
    ws1.Rows(1).Copy ws3.Cells(1, 1)
    i = 1
    l = 1
    While ws2.Cells(i, 1) <> ""
        Set re = ws1.Range("A:A").Find(ws2.Cells(i, 1), lookat:=xlWhole)
        l = l + 1
        If re Is Nothing Then
            ws3.Cells(l, 1) = ws.Cells(i, 1)
            ws3.Cells(l, 2) = "non trouvé dans " & ws1.Name
        Else
            re.EntireRow.Copy ws3.Cells(l, 1)
        End If
        i = i + 1
    Wend
    For i = 2 To l
        While Cells(1, i) <> Cells(i, 1)
            Columns(i).Delete shift:=xlLeft
        Wend
    Next i
End Sub

Bonsoir,

Désolé, mais je ne sais pas pourquoi le code est extrêmement long. Je l'ai lancé et 5 min après Excel en réponse toujours pas et il y a quelque chose d'étrange, je reste bloqué sur la Feuil1 qui ne comporte plus que deux colonnes

Bonsoir, tester alors une approche plus simple au résultat instantané de mon côté !

Sub Demo()
    Application.ScreenUpdating = False
                            VA = Application.Transpose(Feuil2.Cells(1).CurrentRegion)

    With Feuil1.Cells(1).CurrentRegion
        For N& = 2 To .Columns.Count
            If IsError(Application.Match(.Cells(N).Value, VA, 0)) Then
                .Columns(N).Hidden = True
                   .Rows(N).Hidden = True
            End If
        Next

        Feuil3.UsedRange.Clear
        .SpecialCells(xlCellTypeVisible).Copy Feuil3.Cells(1)
        .Columns.Hidden = False
           .Rows.Hidden = False
    End With

    Feuil3.Activate
End Sub

Sa fonctionne parfaitement merci.