Filtrer horizontalement

Bonjour,

J'ai un fichier qui se pressente comme ça :

Dans la colonne A il y a des noms. Sur chaque ligne de nom, un code qui concerne ce nom. Ces données sont en fait une copie de la colonne I de toutes les feuilles de travail.

Comment automatiser le filtrage ? Je souhaite supprimer les cellules vides, supprimer les doublons.

Je vous remercie d'avance pour votre aide.

J'en profite aussi pour demander une astuce.

Voici mon code qui récupère ces données:

Option Explicit

Sub codefac()

Dim ws As Worksheet
Dim nombre As Integer
Dim feuilles As Integer

feuilles = Worksheets.Count
nombre = 1

For Each ws In Worksheets
    If nombre = feuilles Then
        Exit For
    End If

    Worksheets("Index").Cells(nombre, 1).Value = ws.Name
    Worksheets(nombre).Range("I6:I2000").Copy
    Worksheets("Index").Cells(nombre, 2).PasteSpecial Transpose:=True
    nombre = nombre + 1
Next

Comme vous pouvez le voir, je fais un :

Worksheets(nombre).Range("I6:I2000").Copy

C'est assez moche avec le I2000.

Comment remplacer le I2000 par, "Va jusqu'à la dernière ligne utilisée ?

Grand merci pour votre aide.

Bonjour

Tu devrais joindre ton fichier, ce serait plus clair.

Bye !

Bonjour,

Je suis désolé je pensais que ça allait être clair.

Comme le fichier est confidentiel, j'ai fait un classeur démo.

Le résultat est sur la feuille Index.

Je souhaite supprimer les doublons et les cellules vides afin d'avoir un aperçu rapide et clair et codes de facturation pour chaque médecin.

Bonjour,

Teste cette macro

Option Explicit

Sub codefac()
Dim Dl%, i%, l%, n%

Dim ws As Worksheet
Dim nombre As Integer
Dim feuilles As Integer

feuilles = Worksheets.Count
nombre = 1

For Each ws In Worksheets
    If nombre = feuilles Then
        Exit For
    End If

    Worksheets("Index").Cells(nombre, 1).Value = ws.Name
    Dl = ws.Range("I" & Rows.Count).End(xlUp).Row
    Worksheets(nombre).Range("I6:I" & Dl).Copy
    Worksheets("Index").Cells(nombre, 2).PasteSpecial Transpose:=True
    nombre = nombre + 1
Next
    Application.ScreenUpdating = False
    With Worksheets("Index")
      For l = 1 To Range("A" & Rows.Count).End(xlUp).Row
        n = .Cells(l, Columns.Count).End(xlToLeft).Column - 1
          For i = n To 2 Step -1
              If Cells(l, i) = "" Then .Cells(l, i).Delete Shift:=xlToLeft
          Next i
        Next l
    End With

End Sub