Sélection cellule avec condition

Florian53 · 12 Octobre 2017

Bonjour,

Je souhaiterais avoir une selection variable de cellule avec comme condition toutes les cellules commencent par A et que cette sélection soit enregistrer dans un nom.

J'ai essayé de réaliser un code mais celui ci ne fonctionne pas, avez vous une idée ?

VB:

Sub Test()
Dim valeurCherchée As String
Dim champRecherche As Range
Dim résultat As Range

Derniereligne = Range("A3").End(xlDown).Row


valeurCherchée = "A*"
Set champRecherche = Sheets("BDD").Range("A3:A" & Derniereligne)
Set résultat = champRecherche.Find(valeurCherchée, LookIn:=xlValues, LookAt:=xlPart)
If Not résultat Is Nothing Then
Selection.Activate
Selection.Name = "Selection"
End If
End Sub

Merci

pierrejean · 12 Octobre 2017

Bonjour Florian

A tester:

Code:

Sub Test()
Dim valeurCherchée As String
Dim champRecherche As Range
Dim résultat As Range
Dim zone As Range
Derniereligne = Range("A" & Rows.Count).End(xlUp).Row
valeurCherchée = "A*"
Set champRecherche = Sheets("BDD").Range("A3:A" & Derniereligne)
Set résultat = champRecherche.Find(valeurCherchée, LookIn:=xlValues, LookAt:=xlPart)
If Not résultat Is Nothing Then
        firstAddress = résultat.Address
        Do
              If Not zone Is Nothing Then
                  Set zone = Application.Union(zone, résultat)
               Else
                   Set zone = résultat
                End If
            Set résultat = champRecherche.FindNext(résultat)
        Loop While Not résultat Is Nothing And résultat.Address <> firstAddress
    End If
    zone.Select
    zone.Name = "Selection"
End Sub

job75 · 12 Octobre 2017

Bonjour Florian53, Pierre,

Code:

Sub NommerPlage()
Dim valeurCherchée$, champRecherche As Range, t
valeurCherchée = "A*"
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  t = champRecherche 'mémorisation
  Application.ScreenUpdating = False
  champRecherche.Replace valeurCherchée, "#N/A", xlWhole, MatchCase:=True 'la casse est respectée
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeConstants, 16).Name = "Selection"
  champRecherche = t 'restitution
End With
End Sub

Comme toutes les formules, celle définissant le nom "Selection" est limitée à 8192 caractères.

A+

job75 · 12 Octobre 2017

Re,

Au post précédent j'ai supposé que champRecherche ne contient que des constantes.

S'il peut y avoir des formules utiliser cette macro :

Code:

Sub NommerPlage()
Dim valeurCherchée$, champRecherche As Range, t
valeurCherchée = "A*"
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  t = champRecherche.Formula 'mémorisation des constantes et formules
  Application.ScreenUpdating = False
  champRecherche = champRecherche.Value 'suppression des formules
  champRecherche.Replace valeurCherchée, "#N/A", xlWhole, MatchCase:=True 'la casse est respectée
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeConstants, 16).Name = "Selection"
  champRecherche = t 'restitution
End With
End Sub

qui fonctionne dans tous les cas de figure.

A+

job75 · 12 Octobre 2017

Re,

S'il n'est pas nécessaire de respecter la casse, le filtre automatique est une excellente solution :

Code:

Sub NommerPlageFiltre()
Dim valeurCherchée$, champRecherche As Range
valeurCherchée = "A*"
Application.ScreenUpdating = False
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  If IsEmpty(champRecherche(0)) Then champRecherche(0) = Chr(1) 'titre provisoire
  .Range(champRecherche(0), champRecherche).AutoFilter 1, valeurCherchée 'filtre automatique
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeVisible).Name = "Selection"
  .AutoFilterMode = False 'retire le filtre automatique
  If champRecherche(0) = Chr(1) Then champRecherche(0) = Empty
End With
End Sub

A+

Florian53 · 12 Octobre 2017

job75 à dit:

Re,

Au post précédent j'ai supposé que champRecherche ne contient que des constantes.

S'il peut y avoir des formules utiliser cette macro :

Code:

Sub NommerPlage()
Dim valeurCherchée$, champRecherche As Range, t
valeurCherchée = "A*"
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  t = champRecherche.Formula 'mémorisation des constantes et formules
  Application.ScreenUpdating = False
  champRecherche = champRecherche.Value 'suppression des formules
  champRecherche.Replace valeurCherchée, "#N/A", xlWhole, MatchCase:=True 'la casse est respectée
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeConstants, 16).Name = "Selection"
  champRecherche = t 'restitution
End With
End Sub

qui fonctionne dans tous les cas de figure.

A+

Bonsoir,

Cette solution ci dessus fonctionne parfaitement, comme je dois respecter les cases.

Merci à vs et bonne soirée

Florian53 · 13 Octobre 2017

job75 à dit:

Re,

S'il n'est pas nécessaire de respecter la casse, le filtre automatique est une excellente solution :

Code:

Sub NommerPlageFiltre()
Dim valeurCherchée$, champRecherche As Range
valeurCherchée = "A*"
Application.ScreenUpdating = False
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  If IsEmpty(champRecherche(0)) Then champRecherche(0) = Chr(1) 'titre provisoire
  .Range(champRecherche(0), champRecherche).AutoFilter 1, valeurCherchée 'filtre automatique
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeVisible).Name = "Selection"
  .AutoFilterMode = False 'retire le filtre automatique
  If champRecherche(0) = Chr(1) Then champRecherche(0) = Empty
End With
End Sub

A+

Bonjour, j'ai re testé cette solution car je croyais avoir un résultat filtré sans doublons mais à priori ce n'est pas le cas.
Est possible d'avoir cette sélection filtré sans doublons ?

Merci

Florian53 · 13 Octobre 2017

Du coup j'ai appliqué ce code :

VB:

Sub Création_Ma_Liste()

'S'assure qu'il n'y a pas déjà des vieilles données
'sur la plage de résultat.
Feuil4.Range("A:A").Clear

With Sheets("BDD")

With .Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Effectue un filtre élaboré pour enlever les doublons
'et copie le résultat sur la feuil2
.AdvancedFilter xlFilterCopy, , Feuil4.Range("a1"), True
End With
End With
With Feuil4
With Feuil4.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Tri le résultat du filtre en ordre croissant
.Sort .Item(1, 1), xlAscending, , , , , , xlNo
'Affecte un NOM à la plage de résultat
.Name = "MaListe"
End With
'masque la feuille et elle est inaccesible par
'l'interface de la feuille de calcul.
'.Visible = xlSheetVeryHidden
End With

End Sub

et par la suite j'ai utilisé celui ci :

VB:

Sub NommerPlageFiltre()
Dim valeurCherchée$, champRecherche As Range
valeurCherchée = "A*"
Application.ScreenUpdating = False
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  If IsEmpty(champRecherche(0)) Then champRecherche(0) = Chr(1) 'titre provisoire
  .Range(champRecherche(0), champRecherche).AutoFilter 1, valeurCherchée 'filtre automatique
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeVisible).Name = "Selection"
  .AutoFilterMode = False 'retire le filtre automatique
  If champRecherche(0) = Chr(1) Then champRecherche(0) = Empty
End With
End Sub

ça à l'air de fonctionner

job75 · 13 Octobre 2017

Bonjour Florian53,

Le filtre automatique ne permet pas d'éliminer les doublons.

Pour y parvenir on peut compléter le filtrage avec le Dictionary :

Code:

Sub NommerPlageFiltreAuto()
Dim valeurCherchée$, champRecherche As Range, d As Object, c As Range, P As Range
valeurCherchée = "A*"
Application.ScreenUpdating = False
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  If IsEmpty(champRecherche(0)) Then champRecherche(0) = Chr(1) 'titre provisoire
  .Range(champRecherche(0), champRecherche).AutoFilter 1, valeurCherchée 'filtre automatique
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeVisible).Name = "Selection"
  .AutoFilterMode = False 'retire le filtre automatique
  If champRecherche(0) = Chr(1) Then champRecherche(0) = Empty
  '---élimination des doublons---
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = vbTextCompare 'la casse est ignorée
  For Each c In .Range("Selection")
    If Not d.exists(c.Value) Then d(c.Value) = "": Set P = Union(IIf(P Is Nothing, c, P), c)
  Next
  P.Name = "Selection"
End With
End Sub

Ou alors plus simplement utiliser le filtre avancé avec l'argument Unique à True :

Code:

Sub NommerPlageFiltreAvancé()
Dim valeurCherchée$, champRecherche As Range, mem$
valeurCherchée = "A*"
Application.ScreenUpdating = False
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = .Range("A3", .[A3].End(xlDown))
  If IsEmpty(champRecherche(0)) Then champRecherche(0) = Chr(1) 'titre provisoire
  mem = .[B3].Formula 'mémorisation
  .[B3] = "=SEARCH(""" & valeurCherchée & """,A3)=1" 'critère du filtre
  .Range(champRecherche(0), champRecherche).AdvancedFilter xlFilterInPlace, .[B2:B3], Unique:=True 'filtre avancé sans doublon
  On Error Resume Next
  ThisWorkbook.Names("Selection").Delete 'RAZ
  champRecherche.SpecialCells(xlCellTypeVisible).Name = "Selection"
  .ShowAllData
  .[B3] = mem
  If champRecherche(0) = Chr(1) Then champRecherche(0) = Empty
End With
End Sub

A+

job75 · 13 Octobre 2017

Re,

J'ai cru comprendre que vous vouliez respecter la casse, alors voici 2 macros très simples :

Code:

Sub NommerPlageAvecDoublon()
Dim valeurCherchée$, champRecherche As Range, c As Range, P As Range
valeurCherchée = "A*"
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = Intersect(.Range("A3", .[A3].End(xlDown)), .UsedRange)
End With
On Error Resume Next
For Each c In champRecherche
  If c Like valeurCherchée Then Set P = Union(IIf(P Is Nothing, c, P), c)
Next
ThisWorkbook.Names("Selection").Delete 'RAZ
P.Name = "Selection"
End Sub

Sub NommerPlageSansDoublon()
Dim valeurCherchée$, champRecherche As Range, d As Object, c As Range, P As Range
valeurCherchée = "A*"
With Sheets("BDD")
  If .FilterMode Then .ShowAllData 'si la feuille est filtrée
  Set champRecherche = Intersect(.Range("A3", .[A3].End(xlDown)), .UsedRange)
End With
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each c In champRecherche
  If c Like valeurCherchée Then If Not d.exists(c.Value) Then _
    d(c.Value) = "": Set P = Union(IIf(P Is Nothing, c, P), c)
Next
ThisWorkbook.Names("Selection").Delete 'RAZ
P.Name = "Selection"
End Sub

La 1ère macro fait le même travail que celle du post #4 mais elle utilise une boucle...

A+

Sélection cellule avec condition

Florian53

XLDnaute Impliqué

pierrejean

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Florian53

XLDnaute Impliqué

Florian53

XLDnaute Impliqué

Florian53

XLDnaute Impliqué

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires