Philippe Tulliez

Préambule
Pour diverses raisons, nous sommes régulièrement amenés à créer une liste unique de valeurs contenues dans une colonne.

Liste non exhaustive de cas utilisant le nom ou partie du nom de ces éléments exportés

• Créer un tableau
• Créer une feuille
• Effectuer des recherches
• etc.

Code de la procédure nommée PutUniqueValue

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Function PutUniqueValue(oList As ListObject, ColumnLabel As String) As Range
  ' Philippe Tulliez www.magicoffice.be
  ' Date     12-01-2020
  ' Version  1.1
  ' Arguments
  '   oList         Tableau source
  '   ColumnLabel   Nom de l'étiquette de la colonne dont on veut extraire les valeurs uniques
  ' Déclaration
  Dim rngColumn As Range   ' Plage de la colonne de l'argument ColumnLabel
  Dim rngTarget As Range   ' Cellule cible où aura lieu l'exportation de la liste (2ème colonne à gauche de la source)
  ' Assignation
  With oList.Range
    Set rngTarget = .Offset(ColumnOffset:=.Columns.Count + 1).Resize(1, 1)
  End With
  rngTarget.Value = ColumnLabel
  With oList
    Set rngColumn = .ListColumns(ColumnLabel).Range.Resize(.Range.Rows.Count - Abs(.ShowTotals))
  End With
  ' Exportation sans les doublons
  rngColumn.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTarget, Unique:=True
  ' Objet renvoyé par la fonction
  Set PutUniqueValue = rngTarget.CurrentRegion
  ' Fin de la procédure
  Set rngTarget = Nothing: Set rngColumn = Nothing
End Function

Code de la procédure invoquant cette procédure
Cette procédure de test exporte toutes les valeurs, sans les doublons, contenues dans la colonne Région du tableau structuré nommé T_Sales et affiche dans un MsgBox la liste exportée après l'avoir supprimée

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub TestPutUniqueValue()
  Const TableSourceName As String = "T_Sales"
  Const LabelName As String = "Région"
  Dim sht As Worksheet
  Dim oListSource As ListObject
  Dim rngSource As Range
  Dim areaUniqueValue As Range
  Dim Cell As Range
  Dim msg As String
  '
  Set sht = GetListObjectSheet(TableSourceName, ThisWorkbook)
  Set oListSource = sht.ListObjects(TableSourceName)
  Set areaUniqueValue = PutUniqueValue(oListSource, LabelName)
  With areaUniqueValue
    For Each Cell In .Offset(1).Resize(.Rows.Count - 1)
      msg = msg & vbCrLf & Cell.Address & vbTab & Cell.Value
    Next
  .Clear ' On efface la plage après traitement
  End With
  MsgBox msg
  ' Fin de process
  Set oListSource = Nothing: Set rngSource = Nothing: Set areaUniqueValue = Nothing: Set Cell = Nothing
End Sub

Pour voir le code et les explications de la fonction nommée GetListObjectSheet utilisée en ligne 11, voir mon billet Comment vérifier si un tableau structuré existe

Illustration