Macro pour chercher une donnée d'une liste dans toutes les feuilles et remplacer
cs_guda
Messages postés
20
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
11 février 2013
-
19 oct. 2005 à 18:16
valtrase Messages postés 937 Date d'inscription lundi 19 janvier 2004 Statut Membre Dernière intervention 9 mai 2022 - 27 oct. 2005 à 13:14
valtrase Messages postés 937 Date d'inscription lundi 19 janvier 2004 Statut Membre Dernière intervention 9 mai 2022 - 27 oct. 2005 à 13:14
A voir également:
- Macro pour chercher une donnée d'une liste dans toutes les feuilles et remplacer
- Parcourir une liste java - Forum Java
- Vba supprimer une feuille ✓ - Forum VBA Office (Excel, Word ...)
- Macro word remplacer texte ✓ - Forum Visual Basic 6
- Vba copier coller dans une autre feuille ✓ - Forum Visual Basic 6
- Vba copier une feuille dans un autre classeur sans ouvrir - Forum Visual Basic
9 réponses
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
19 oct. 2005 à 19:57
19 oct. 2005 à 19:57
Lut,
Menu edition\Rechercher et là tu choisi ce que tu veux faire
l'onglet Remplacer te permet de remplacer et le bouton Options te donnes plusieurs options notament si tu veux rechercher dans tout le classeur
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
Menu edition\Rechercher et là tu choisi ce que tu veux faire
l'onglet Remplacer te permet de remplacer et le bouton Options te donnes plusieurs options notament si tu veux rechercher dans tout le classeur
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
cs_guda
Messages postés
20
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
11 février 2013
19 oct. 2005 à 21:15
19 oct. 2005 à 21:15
J'ai du mal m'exprimer, en fait ce que je cherche c'est qu'une macro parcours chaque valeur de ma table de correspondance et la remplace dans toutes les feuilles par sa correponsdance issue de la même table.
J'ai 1 000 valeurs alors à faire à la main ça va être un tout petit peu long
J'ai 1 000 valeurs alors à faire à la main ça va être un tout petit peu long
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
19 oct. 2005 à 23:24
19 oct. 2005 à 23:24
Lut,
Voilà un code qui devrait te convenir:
La sub Remplace doit être mise dan un module
Pour l'appel tu fait
Private Sub CommandButton2_Click()
Call Remplace( "corres" , "B2" )
End Sub
'*** Sub Remplace(wsCorres As String
, Départ As String , Optional Décal As Long = 1 )
'*** wsCorres est ta feuille ou se situe ta table de correspondance
'*** Départ est la cellulle de départ des anciens codes
'*** Décal ne sert que si la colonne des nouvelles correspondances n'est pas
'*** contigue à celle des anciènnes
Sub Remplace(wsCorres As String , Départ As String , Optional Décal As Long = 1 )
Dim ws As Worksheet
Dim xlCell: Dim Add
Dim c
Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells( 65536 , cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow,
» cellDépart.Column).Address)
End With
For Each c In OldCor
For Each ws In Worksheets
If ws.Name = wsCorres Then GoTo xlNext
With ws.UsedRange
ws.Select
Set xlCell = .Find(c, LookIn:=xlValues)
If Not xlCell Is Nothing Then
Add = xlCell.Address
Do
xlCell.Select
Select Case MsgBox( "Remplacer la valeur de la cellule ( " & xlCell.Address & _
" ) de la feuille " & ws.Name & " ?" , vbInformation + vbOKCancel)
Case vbOK
xlCell.Value = c.Offset( 0 , Décal).Value
Case vbCancel
End Select
Set xlCell = .FindNext(xlCell)
Loop While ( Not (xlCell Is Nothing ))
End If
End With
xlNext:
Next
Next
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
Voilà un code qui devrait te convenir:
La sub Remplace doit être mise dan un module
Pour l'appel tu fait
Private Sub CommandButton2_Click()
Call Remplace( "corres" , "B2" )
End Sub
'*** Sub Remplace(wsCorres As String
, Départ As String , Optional Décal As Long = 1 )
'*** wsCorres est ta feuille ou se situe ta table de correspondance
'*** Départ est la cellulle de départ des anciens codes
'*** Décal ne sert que si la colonne des nouvelles correspondances n'est pas
'*** contigue à celle des anciènnes
Sub Remplace(wsCorres As String , Départ As String , Optional Décal As Long = 1 )
Dim ws As Worksheet
Dim xlCell: Dim Add
Dim c
Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells( 65536 , cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow,
» cellDépart.Column).Address)
End With
For Each c In OldCor
For Each ws In Worksheets
If ws.Name = wsCorres Then GoTo xlNext
With ws.UsedRange
ws.Select
Set xlCell = .Find(c, LookIn:=xlValues)
If Not xlCell Is Nothing Then
Add = xlCell.Address
Do
xlCell.Select
Select Case MsgBox( "Remplacer la valeur de la cellule ( " & xlCell.Address & _
" ) de la feuille " & ws.Name & " ?" , vbInformation + vbOKCancel)
Case vbOK
xlCell.Value = c.Offset( 0 , Décal).Value
Case vbCancel
End Select
Set xlCell = .FindNext(xlCell)
Loop While ( Not (xlCell Is Nothing ))
End If
End With
xlNext:
Next
Next
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
cs_guda
Messages postés
20
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
11 février 2013
26 oct. 2005 à 11:23
26 oct. 2005 à 11:23
j'ai un souci avec ce code :
arrivé à la ligne : ws.Select
il genere une erreure 1004
pour info je suis sous Excel 2002
Quelqu'un voit le probléme ?
arrivé à la ligne : ws.Select
il genere une erreure 1004
pour info je suis sous Excel 2002
Quelqu'un voit le probléme ?
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
26 oct. 2005 à 11:38
26 oct. 2005 à 11:38
Lut Vérifie que ta feuille existe et qu'elle ne soit pas cachée.
Sinon tu pex testé avec :
ws.Activate
Pour info j'ai testé chez moi avec 2003 et ça tourne bien
sinon tu n'est pas obligé de mettre cette ligne elle ne sert qu'a visualiser la feuille ou se feront les modifs idem pour la ligne xlCell.Select
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
Sinon tu pex testé avec :
ws.Activate
Pour info j'ai testé chez moi avec 2003 et ça tourne bien
sinon tu n'est pas obligé de mettre cette ligne elle ne sert qu'a visualiser la feuille ou se feront les modifs idem pour la ligne xlCell.Select
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
cs_guda
Messages postés
20
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
11 février 2013
26 oct. 2005 à 14:50
26 oct. 2005 à 14:50
Merci, j'ai enlevé cette instruction.
J'ai encore une question, j'ai des colonnes ayant des formules genre
ColA ColB
AB01 =A1 & "test"
AB02 =A2 & "test"
AB03 =A3 & "test"
Donc, il apparait
ColA ColB
AB01 AB01test
AB02 AB02test
AB03 AB03test
Mon souci c'est que la macro va vouloir modifier les valeurs AB01 et va alors écraser ma formule dans la colonne B. est-il possible de lui demander d'ignorer les formules ?
J'ai encore une question, j'ai des colonnes ayant des formules genre
ColA ColB
AB01 =A1 & "test"
AB02 =A2 & "test"
AB03 =A3 & "test"
Donc, il apparait
ColA ColB
AB01 AB01test
AB02 AB02test
AB03 AB03test
Mon souci c'est que la macro va vouloir modifier les valeurs AB01 et va alors écraser ma formule dans la colonne B. est-il possible de lui demander d'ignorer les formules ?
cs_guda
Messages postés
20
Date d'inscription
jeudi 31 janvier 2002
Statut
Membre
Dernière intervention
11 février 2013
26 oct. 2005 à 15:00
26 oct. 2005 à 15:00
Après test, j'ai un gros soucis, si je répond oui pour modifier les données, pas de pb parcontre, en répondant non, il retrouve dans la même ligne la valeur et donc me redemande indéfiniement :
Voici mon code
Sub Remplace(wsCorres As String, Départ As String, Optional Décal As Long = 1)
'Initialisation des variables
Dim ws As Worksheet
Dim xlCell: Dim Add
Dim c
Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells(65536, cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow, cellDépart.Column).Address)
End With
For Each c In OldCor
For Each ws In Worksheets
'On ne traite pas la feuille de transcodification
If ws.Name = wsCorres Then GoTo xlNext
With ws.UsedRange
'on selectionne la feuille lue mais on intercepte les erreurs
'car certaines feuilles n'ont que du code et pas d'objet
On Error Resume Next
ws.Select
If Err.Number > 0 Then GoTo xlNext
On Error GoTo 0
'On recherche dans la feuille les champs contenant la valeur à changer
Set xlCell = .Find(c, LookIn:=xlValues)
'S'il contient quelque chose
If Not xlCell Is Nothing Then
Add = xlCell.Address
Do
xlCell.Select
Select Case MsgBox("Remplacer la valeur '" & xlCell.Value & "' par '" & c.Offset(0, Décal).Value & "'" & vbCrLf & " Cellule " & xlCell.Address & " - feuille " & ws.Name & " ?", vbInformation + vbOKCancel)
Case vbOK
xlCell.Value = c.Offset(0, Décal).Value
Case vbCancel
End Select
Set xlCell = .FindNext(xlCell)
Loop While (Not (xlCell Is Nothing))
End If
End With
xlNext:
Next
Next
End Sub
Y a t-il une erreur ?
Voici mon code
Sub Remplace(wsCorres As String, Départ As String, Optional Décal As Long = 1)
'Initialisation des variables
Dim ws As Worksheet
Dim xlCell: Dim Add
Dim c
Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells(65536, cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow, cellDépart.Column).Address)
End With
For Each c In OldCor
For Each ws In Worksheets
'On ne traite pas la feuille de transcodification
If ws.Name = wsCorres Then GoTo xlNext
With ws.UsedRange
'on selectionne la feuille lue mais on intercepte les erreurs
'car certaines feuilles n'ont que du code et pas d'objet
On Error Resume Next
ws.Select
If Err.Number > 0 Then GoTo xlNext
On Error GoTo 0
'On recherche dans la feuille les champs contenant la valeur à changer
Set xlCell = .Find(c, LookIn:=xlValues)
'S'il contient quelque chose
If Not xlCell Is Nothing Then
Add = xlCell.Address
Do
xlCell.Select
Select Case MsgBox("Remplacer la valeur '" & xlCell.Value & "' par '" & c.Offset(0, Décal).Value & "'" & vbCrLf & " Cellule " & xlCell.Address & " - feuille " & ws.Name & " ?", vbInformation + vbOKCancel)
Case vbOK
xlCell.Value = c.Offset(0, Décal).Value
Case vbCancel
End Select
Set xlCell = .FindNext(xlCell)
Loop While (Not (xlCell Is Nothing))
End If
End With
xlNext:
Next
Next
End Sub
Y a t-il une erreur ?
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
27 oct. 2005 à 00:14
27 oct. 2005 à 00:14
Lut,
Bon pour ta deuxième question c'est la méthode Find qui te crée ce prob, ce soir c'est trop tard mais je vais m'y pencher dessus.
pour ta première question il n'écrase pas du tout puisque dans la 2ème colonne tu lui demande de concaténer la valeur de [A] & "test"donc si
[A] contient R423 [B] contiendra R423test et si
[A] contient AB01 [B] contiendra AB01test
cela n'a rien avoir avec le code mais plutôt ta formule
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
Bon pour ta deuxième question c'est la méthode Find qui te crée ce prob, ce soir c'est trop tard mais je vais m'y pencher dessus.
pour ta première question il n'écrase pas du tout puisque dans la 2ème colonne tu lui demande de concaténer la valeur de [A] & "test"donc si
[A] contient R423 [B] contiendra R423test et si
[A] contient AB01 [B] contiendra AB01test
cela n'a rien avoir avec le code mais plutôt ta formule
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
27 oct. 2005 à 13:14
27 oct. 2005 à 13:14
Re,
voilà les modifs le code est rallongé mais cela te feras une bonne leçon sur qq fonctions d'excel
pour l'appel c'est idem qu'avant.
Je te conseille de mettre les fonctions dans un module par cotégories et ensuite de les exporter dans un répertoire à toi tu pourras par la suite les intégrées dans d'autres projets
Option Explicit
Dim Conv As Integer
Dim T2 As String
Sub Remplace(wsCorres As String , Départ As String , Optional Décal As Long = 1 )
Dim ws As Worksheet: Dim xlCell: Dim Add: Dim C: Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long: Dim Message As String
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells( 65536 , cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow,
» cellDépart.Column).Address)
End With
For Each C In OldCor
For Each ws In Worksheets
If ws.Name = wsCorres Then GoTo xlNext
ws.Activate
For Each xlCell In ws.UsedRange
' j'ai intégré la suppression d'accent pour éviter les erreurs
If SupprAccents(xlCell.Value, 1 ) = SupprAccents(C.Value, 1 ) Then
xlCell.Select
'*** Ici pour la simplicité tu peux mettre une simple msgbox
'*** j'ai rajouté une boite de dialogue personalisée qui te permet soit
» d'enregistrer
'*** soit d'ignorer soit de sortir
Message = "Remplacer la valeur de la cellule " & StrAddress(xlCell.Address) & _
"Anciènne valeur: " & xlCell.Value & " Nouvelle Valeur: " & C.Offset( 0 , Dé
» cal).Value & _
" de la feuille " & ws.Name & " ?"
Select Case BBmsgbox( 1 , vbYesNoCancel, _
"Remplacement de Valeur" , Message, , "Remplacer" , "Ignorer" , "Sortir" )
Case "Remplacer"
xlCell.Value = C.Offset( 0 , Décal).Value
Case "Ignorer"
Case "Sortir"
Exit Sub
End Select
End If
Next
xlNext:
Next
Next
End Sub
'*** Cette fonction te permet de mettre en majuscule est de supprimé les accents
'*** elle peut être mise dans un module
'*** Elle doit être accompagnée de la fonction Convert
Function SupprAccents(Texte As String , Optional Casse) As String
'Si Casse =0 pas de changement; 1= Minuscule; 2=Majuscule
Dim i As Integer
Dim C As String * 1
If IsMissing (Casse) Then Conv 0 Else Conv Casse
T2 = ""
For i = 1 To Len (Texte)
C = Mid$ (Texte, i, 1 )
Select Case C
Case "A" To "Z" : Convert 1 , LCase$ (C), C
Case "a" To "z" : Convert 2 , UCase$ (C), C
Case "è" To "ë" : Convert 2 , "E" , "e"
Case "à" To "å" : Convert 2 , "A" , "a"
Case "ò" To "ö" : Convert 2 , "O" , "o"
Case "ù" To "ü" : Convert 2 , "U" , "u"
Case "ç" : Convert 2 , "C" , "c"
Case "È" To "Ë" : Convert 1 , "e" , "E"
Case "À" To "Å" : Convert 1 , "a" , "A"
Case "Ò" To "Ö" : Convert 1 , "o" , "O"
Case "Ù" To "Ü" : Convert 1 , "u" , "U"
Case "Ç" : Convert 1 , "c" , "C"
Case "ì" To "ï" : Convert 2 , "I" , "i"
Case "ñ" : Convert 2 , "N" , "n"
Case "š" : Convert 2 , "S" , "s"
Case Chr$ ( 158 ): Convert 2 , "Z" , "z"
Case "ý" , "ÿ" : Convert 2 , "Y" , "y"
Case "Ì" To "Ï" : Convert 1 , "i" , "I"
Case "Ñ" : Convert 1 , "n" , "N"
Case "Š" : Convert 1 , "s" , "S"
Case Chr$ ( 142 ): Convert 1 , "z" , "Z"
Case "Ý" , "Ÿ" : Convert 1 , "y" , "Y"
Case Else: T2 = T2 & C
End Select
Next i
SupprAccents = T2
End Function
Private Function Convert(Cdt As Integer , _
R1 As String , R2 As String ) As String
If Conv Cdt Then T2 T2 & R1 Else T2 = T2 & R2
End Function
'*** Fonction personnalisée juste pour l'affichage
'*** Une entrée de $A$1 renvoi [A1]
Private Function StrAddress(xlAddress As String ) As String
If InStr ( 1 , xlAddress, "$" ) Then
StrAddress = "[" & Replace(xlAddress, "$" , "" ) & "]"
Else
StrAddress = xlAddress
End If
End Function
'***' MessageBox personnalisée (titre, invite, noms des boutons)
'*** Ce code vient de la toile et est signé MPF
'*********************************************************************************
'*** CE CODE EST A METTRE DANS UN MODULE
'*********************************************************************************
Private Const MB_YESNOCANCEL = &H3&
Private Const MB_YESNO = &H4&
Private Const MB_RETRYCANCEL = &H5&
Private Const MB_OKCANCEL = &H1&
Private Const MB_OK = &H0&
Private Const MB_ABORTRETRYIGNORE = &H2&
Private Const MB_ICONEXCLAMATION = &H30&
Private Const MB_ICONQUESTION = &H20&
Private Const MB_ICONASTERISK = &H40&
Private Const MB_ICONINFORMATION = MB_ICONASTERISK
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF&
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (- 6 )
Private Const HCBT_ACTIVATE = 5
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" ( ByVal hwnd As Long , ByVal nIndex As Long ) As Long
Private Declare Function MessageBox Lib "user32" Alias _
"MessageBoxA" ( ByVal hwnd As Long , ByVal lpText As String , _
ByVal lpCaption As String , ByVal wType As Long ) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias _
"SetDlgItemTextA" ( ByVal hDlg As Long , ByVal nIDDlgItem As Long , _
ByVal lpString As String ) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" ( ByVal idHook As Long , ByVal lpfn As Long , _
ByVal hmod As Long , ByVal dwThreadId As Long ) As Long
Private Declare Function SetWindowText Lib "user32" Alias _
"SetWindowTextA" ( ByVal hwnd As Long , ByVal lpString As String ) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
( ByVal hHook As Long ) As Long
Dim mbFlags As VbMsgBoxStyle
Dim mbFlags2 As VbMsgBoxStyle
Dim mTitle As String
Dim mPrompt As String
Dim But1 As String
Dim But2 As String
Dim But3 As String
Public Function MessageBoxH(hwndThreadOwner As Long , _
hwndOwner As Long , mbFlags As VbMsgBoxStyle) As Long
'This function calls the hook
Dim hInstance As Long
Dim hThreadId As Long
hInstance = GetWindowLong (hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId ()
With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx (WH_CBT, AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MessageBoxH = MessageBox (hwndOwner, Space$ ( 120 ), Space$ ( 120 ), mbFlags)
End Function
Public Function MsgBoxHookProc( ByVal uMsg As Long , _
ByVal wParam As Long , ByVal lParam As Long ) As Long
'This function catches the messagebox before it opens
'and changes the text of the buttons - then removes the hook
If uMsg = HCBT_ACTIVATE Then
SetWindowText wParam, mTitle
SetDlgItemText wParam, IDPROMPT, mPrompt
Select Case mbFlags
Case vbAbortRetryIgnore
SetDlgItemText wParam, IDABORT, But1
SetDlgItemText wParam, IDRETRY, But2
SetDlgItemText wParam, IDIGNORE, But3
Case vbYesNoCancel
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
SetDlgItemText wParam, IDCANCEL, But3
Case vbOKOnly
SetDlgItemText wParam, IDOK, But1
Case vbRetryCancel
SetDlgItemText wParam, IDRETRY, But1
SetDlgItemText wParam, IDCANCEL, But2
Case vbYesNo
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
Case vbOKCancel
SetDlgItemText wParam, IDOK, But1
SetDlgItemText wParam, IDCANCEL, But2
End Select
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Public Function BBmsgbox(mhwnd As Long , _
mMsgbox As VbMsgBoxStyle, Title As String , _
Prompt As String , Optional mMsgIcon As VbMsgBoxStyle, _
Optional ButA As String , Optional ButB As String , _
Optional ButC As String ) As String
'This function sets your custom parameters and returns
'which button was pressed as a string
Dim mReturn As Long
mbFlags = mMsgbox
mbFlags2 = mMsgIcon
mTitle = Title
mPrompt = Prompt
But1 = ButA
But2 = ButB
But3 = ButC
mReturn = MessageBoxH(mhwnd, GetDesktopWindow (), _
mbFlags Or mbFlags2)
Select Case mReturn
Case IDABORT
BBmsgbox = But1
Case IDRETRY
BBmsgbox = But2
Case IDIGNORE
BBmsgbox = But3
Case IDYES
BBmsgbox = But1
Case IDNO
BBmsgbox = But2
Case IDCANCEL
BBmsgbox = But3
Case IDOK
BBmsgbox = But1
End Select
End Function
Sub Test()
Dim mReturn As String
mReturn = BBmsgbox( 1 , vbYesNoCancel, _
"Hi There" , "Cool ?" , , "Go for it" , "No way" , "Let me think" )
MsgBox "You pressed " + mReturn
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
voilà les modifs le code est rallongé mais cela te feras une bonne leçon sur qq fonctions d'excel
pour l'appel c'est idem qu'avant.
Je te conseille de mettre les fonctions dans un module par cotégories et ensuite de les exporter dans un répertoire à toi tu pourras par la suite les intégrées dans d'autres projets
Option Explicit
Dim Conv As Integer
Dim T2 As String
Sub Remplace(wsCorres As String , Départ As String , Optional Décal As Long = 1 )
Dim ws As Worksheet: Dim xlCell: Dim Add: Dim C: Dim OldCor As Range
Dim cellDépart As Range: Dim Lastrow As Long: Dim Message As String
With Sheets(wsCorres)
Set cellDépart = .Range(Départ)
Lastrow = .Cells( 65536 , cellDépart.Column).End(xlUp).Row
Set OldCor = .Range(Cells(cellDépart.Row, cellDépart.Column).Address, Cells(Lastrow,
» cellDépart.Column).Address)
End With
For Each C In OldCor
For Each ws In Worksheets
If ws.Name = wsCorres Then GoTo xlNext
ws.Activate
For Each xlCell In ws.UsedRange
' j'ai intégré la suppression d'accent pour éviter les erreurs
If SupprAccents(xlCell.Value, 1 ) = SupprAccents(C.Value, 1 ) Then
xlCell.Select
'*** Ici pour la simplicité tu peux mettre une simple msgbox
'*** j'ai rajouté une boite de dialogue personalisée qui te permet soit
» d'enregistrer
'*** soit d'ignorer soit de sortir
Message = "Remplacer la valeur de la cellule " & StrAddress(xlCell.Address) & _
"Anciènne valeur: " & xlCell.Value & " Nouvelle Valeur: " & C.Offset( 0 , Dé
» cal).Value & _
" de la feuille " & ws.Name & " ?"
Select Case BBmsgbox( 1 , vbYesNoCancel, _
"Remplacement de Valeur" , Message, , "Remplacer" , "Ignorer" , "Sortir" )
Case "Remplacer"
xlCell.Value = C.Offset( 0 , Décal).Value
Case "Ignorer"
Case "Sortir"
Exit Sub
End Select
End If
Next
xlNext:
Next
Next
End Sub
'*** Cette fonction te permet de mettre en majuscule est de supprimé les accents
'*** elle peut être mise dans un module
'*** Elle doit être accompagnée de la fonction Convert
Function SupprAccents(Texte As String , Optional Casse) As String
'Si Casse =0 pas de changement; 1= Minuscule; 2=Majuscule
Dim i As Integer
Dim C As String * 1
If IsMissing (Casse) Then Conv 0 Else Conv Casse
T2 = ""
For i = 1 To Len (Texte)
C = Mid$ (Texte, i, 1 )
Select Case C
Case "A" To "Z" : Convert 1 , LCase$ (C), C
Case "a" To "z" : Convert 2 , UCase$ (C), C
Case "è" To "ë" : Convert 2 , "E" , "e"
Case "à" To "å" : Convert 2 , "A" , "a"
Case "ò" To "ö" : Convert 2 , "O" , "o"
Case "ù" To "ü" : Convert 2 , "U" , "u"
Case "ç" : Convert 2 , "C" , "c"
Case "È" To "Ë" : Convert 1 , "e" , "E"
Case "À" To "Å" : Convert 1 , "a" , "A"
Case "Ò" To "Ö" : Convert 1 , "o" , "O"
Case "Ù" To "Ü" : Convert 1 , "u" , "U"
Case "Ç" : Convert 1 , "c" , "C"
Case "ì" To "ï" : Convert 2 , "I" , "i"
Case "ñ" : Convert 2 , "N" , "n"
Case "š" : Convert 2 , "S" , "s"
Case Chr$ ( 158 ): Convert 2 , "Z" , "z"
Case "ý" , "ÿ" : Convert 2 , "Y" , "y"
Case "Ì" To "Ï" : Convert 1 , "i" , "I"
Case "Ñ" : Convert 1 , "n" , "N"
Case "Š" : Convert 1 , "s" , "S"
Case Chr$ ( 142 ): Convert 1 , "z" , "Z"
Case "Ý" , "Ÿ" : Convert 1 , "y" , "Y"
Case Else: T2 = T2 & C
End Select
Next i
SupprAccents = T2
End Function
Private Function Convert(Cdt As Integer , _
R1 As String , R2 As String ) As String
If Conv Cdt Then T2 T2 & R1 Else T2 = T2 & R2
End Function
'*** Fonction personnalisée juste pour l'affichage
'*** Une entrée de $A$1 renvoi [A1]
Private Function StrAddress(xlAddress As String ) As String
If InStr ( 1 , xlAddress, "$" ) Then
StrAddress = "[" & Replace(xlAddress, "$" , "" ) & "]"
Else
StrAddress = xlAddress
End If
End Function
'***' MessageBox personnalisée (titre, invite, noms des boutons)
'*** Ce code vient de la toile et est signé MPF
'*********************************************************************************
'*** CE CODE EST A METTRE DANS UN MODULE
'*********************************************************************************
Private Const MB_YESNOCANCEL = &H3&
Private Const MB_YESNO = &H4&
Private Const MB_RETRYCANCEL = &H5&
Private Const MB_OKCANCEL = &H1&
Private Const MB_OK = &H0&
Private Const MB_ABORTRETRYIGNORE = &H2&
Private Const MB_ICONEXCLAMATION = &H30&
Private Const MB_ICONQUESTION = &H20&
Private Const MB_ICONASTERISK = &H40&
Private Const MB_ICONINFORMATION = MB_ICONASTERISK
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF&
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (- 6 )
Private Const HCBT_ACTIVATE = 5
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" ( ByVal hwnd As Long , ByVal nIndex As Long ) As Long
Private Declare Function MessageBox Lib "user32" Alias _
"MessageBoxA" ( ByVal hwnd As Long , ByVal lpText As String , _
ByVal lpCaption As String , ByVal wType As Long ) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias _
"SetDlgItemTextA" ( ByVal hDlg As Long , ByVal nIDDlgItem As Long , _
ByVal lpString As String ) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" ( ByVal idHook As Long , ByVal lpfn As Long , _
ByVal hmod As Long , ByVal dwThreadId As Long ) As Long
Private Declare Function SetWindowText Lib "user32" Alias _
"SetWindowTextA" ( ByVal hwnd As Long , ByVal lpString As String ) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
( ByVal hHook As Long ) As Long
Dim mbFlags As VbMsgBoxStyle
Dim mbFlags2 As VbMsgBoxStyle
Dim mTitle As String
Dim mPrompt As String
Dim But1 As String
Dim But2 As String
Dim But3 As String
Public Function MessageBoxH(hwndThreadOwner As Long , _
hwndOwner As Long , mbFlags As VbMsgBoxStyle) As Long
'This function calls the hook
Dim hInstance As Long
Dim hThreadId As Long
hInstance = GetWindowLong (hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId ()
With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx (WH_CBT, AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MessageBoxH = MessageBox (hwndOwner, Space$ ( 120 ), Space$ ( 120 ), mbFlags)
End Function
Public Function MsgBoxHookProc( ByVal uMsg As Long , _
ByVal wParam As Long , ByVal lParam As Long ) As Long
'This function catches the messagebox before it opens
'and changes the text of the buttons - then removes the hook
If uMsg = HCBT_ACTIVATE Then
SetWindowText wParam, mTitle
SetDlgItemText wParam, IDPROMPT, mPrompt
Select Case mbFlags
Case vbAbortRetryIgnore
SetDlgItemText wParam, IDABORT, But1
SetDlgItemText wParam, IDRETRY, But2
SetDlgItemText wParam, IDIGNORE, But3
Case vbYesNoCancel
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
SetDlgItemText wParam, IDCANCEL, But3
Case vbOKOnly
SetDlgItemText wParam, IDOK, But1
Case vbRetryCancel
SetDlgItemText wParam, IDRETRY, But1
SetDlgItemText wParam, IDCANCEL, But2
Case vbYesNo
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
Case vbOKCancel
SetDlgItemText wParam, IDOK, But1
SetDlgItemText wParam, IDCANCEL, But2
End Select
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Public Function BBmsgbox(mhwnd As Long , _
mMsgbox As VbMsgBoxStyle, Title As String , _
Prompt As String , Optional mMsgIcon As VbMsgBoxStyle, _
Optional ButA As String , Optional ButB As String , _
Optional ButC As String ) As String
'This function sets your custom parameters and returns
'which button was pressed as a string
Dim mReturn As Long
mbFlags = mMsgbox
mbFlags2 = mMsgIcon
mTitle = Title
mPrompt = Prompt
But1 = ButA
But2 = ButB
But3 = ButC
mReturn = MessageBoxH(mhwnd, GetDesktopWindow (), _
mbFlags Or mbFlags2)
Select Case mReturn
Case IDABORT
BBmsgbox = But1
Case IDRETRY
BBmsgbox = But2
Case IDIGNORE
BBmsgbox = But3
Case IDYES
BBmsgbox = But1
Case IDNO
BBmsgbox = But2
Case IDCANCEL
BBmsgbox = But3
Case IDOK
BBmsgbox = But1
End Select
End Function
Sub Test()
Dim mReturn As String
mReturn = BBmsgbox( 1 , vbYesNoCancel, _
"Hi There" , "Cool ?" , , "Go for it" , "No way" , "Let me think" )
MsgBox "You pressed " + mReturn
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
