Const COLOR_INDEX_ROUGE = 3
Const COLOR_INDEX_VERT = 7
Const COLONNES_RECHERCHE = "D,C" 'Ordre des 2 colonnes de recherche
Const COLONNE_NOUVELLES_REF = "C" 'Colonne pour les nouvelles valeurs
Sub ModiferMenuContextuelCells()
RétablirMenuContextuelCells
With Application.CommandBars("Cell").Controls.Add(msoControlButton)
.Tag = "optRechercheRef"
.Caption = "Recherche référence"
.OnAction = "LancerRecherche"
End With
End Sub
Public Sub RétablirMenuContextuelCells()
On Error Resume Next
'Première méthode de suppression
Application.CommandBars("Cell").Controls("Recherche référence").Delete
If Err.Number > 0 Then
Err.Clear
'En cas d'échec, deuxième méthode de suppression
Application.CommandBars("Cell").FindControl(Tag:="optRechercheRef").Delete
'En cas d'échec de la deuxièmen rétablir le menu contextuel par défaut
If Err.Number > 0 Then Application.CommandBars("Cell").Reset
End If
End Sub
Public Sub LancerRecherche()
If ActiveCell.Column <> 3 Then ActiveSheet.Cells(ActiveCell.Row, 3).Select
usfChercherRef.Show
End Sub
Public Sub ChercherNum(ByVal sNomFeuille As String, sValeur As String, Optional OptColonnesRechecher As Byte = 6)
'
'-------------------Déclaration des variables
'
Dim sh As Worksheet 'Feuille de recherche
Dim plageRecherche As Range 'Plage de recherche colonne(vntColonne)
Dim Cellule As Range 'Cellule de référence de l'occurence trouvée ou rien
Dim NumRang As Variant 'Numéro de rang de la Valeur trouvée à partir de la celllule 1 de la colonne de recherche
' On Error Resume Next
'
'--------------------Feuille de calcul pour la recherche
'
Set sh = ThisWorkbook.Sheets(sNomFeuille)
If Err.Number > 0 Then
MsgBox "La feuille '" & sNomFeuille & "' n'a pas été trouvée." & vbCrLf & vbCrLf & _
"Impossible de continuer la recherche!" & _
"Vérifiez qu'elle existe bien et recommencez.", vbExclamation, "ChercherNum"
Exit Sub
End If
Err.Clear
'
'---------------------Colonne de recherche
'
Set plageRecherche = sh.Columns(Split(COLONNES_RECHERCHE, ",")(0))
Err.Clear
'On Error GoTo FIN_Recherche
NumRang = Application.Match(sValeur, plageRecherche, 0)
If IsError(NumRang) Then
Set plageRecherche = sh.Columns(Split(COLONNES_RECHERCHE, ",")(1))
NumRang = Application.Match(sValeur, plageRecherche, 0)
End If
'Si aucune cellule contenant 'sValeur' a été trouvée
'
If IsError(NumRang) Then
'
'Référencer la cellule sous la dernière cellule non vide de la colonne de recherche
'
Set Cellule = sh.Range(COLONNE_NOUVELLES_REF & sh.Rows.Count).End(xlUp).Offset(1)
'
'y placer la valeur et passer la couleur d'écriture en rouge
'
With Cellule
.Value = sValeur
.Font.ColorIndex = COLOR_INDEX_ROUGE
End With
Else
Set Cellule = plageRecherche.Cells(plageRecherche.Row + NumRang - 1, 1)
Cellule.Font.ColorIndex = COLOR_INDEX_VERT
End If
'
'Se déplace à la cellule trouvée ou à la nouvelle cellule
'
Application.Goto reference:=Cellule
FIN_Recherche:
If Err.Number > 0 Then
MsgBox "Une erreur s'est produite lors de la recherche de '" & sValeur & "'" & vbCrLf & vbCrLf _
& "Erreur numéro : " & Err.Number & vbCrLf _
& "Description : " & Err.Description & vbCrLf & vbCrLf _
& "Fermez la fenêtre et recommencez.", vbExclamation, "Chercher une référence"
End If
End Sub
Le cas échéant je peux remonter le fil.
