je souhaite avoir le detail d une cellule on m a deja donné la macro
suivante :
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("e:e")) Is Nothing Then
Target.Offset(0, 1).Value = "'" & Target.Formula
End If
End Sub
Qui marche tres bien lorsqu on tape directement la formule
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Carim
Bonjour,
Juste une première étape test ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings ... à affiner cel1 = Mid(Target.Offset(0, 1), 2, 2) cel2 = Mid(Target.Offset(0, 1), 5, 2) 'Expliciter la Formule Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, Range(cel1).Value) _ , cel2, Range(cel2).Value) End If End Sub
A+
Bonjour,
Juste une première étape test ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As String
Dim cel2 As String
If Not Intersect(Target, Range("e:e")) Is Nothing Then
Target.Offset(0, 1).Value = "'" & Target.Formula
'Extraction des Strings ... à affiner
cel1 = Mid(Target.Offset(0, 1), 2, 2)
cel2 = Mid(Target.Offset(0, 1), 5, 2)
'Expliciter la Formule
Target.Offset(0, 2).Value = "'" &
Application.WorksheetFunction.Substitute _
(Application.WorksheetFunction.Substitute(Target.Offset(0, 1),
cel1, Range(cel1).Value) _
, cel2, Range(cel2).Value)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings ... à affiner cel1 = Mid(Target.Offset(0, 1), 2, 2) cel2 = Mid(Target.Offset(0, 1), 5, 2) 'Expliciter la Formule Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, Range(cel1).Value) _ , cel2, Range(cel2).Value) End If End Sub
A+
titi
bonjour
heu non ca marche pas j ai l erreur 1004 la methode "range" de l'objet "_Worksheet" a échoué
si tu as des compléments a faire je suis preneur
a+ th
"Carim" a écrit dans le message de groupe de discussion :
Bonjour,
Juste une première étape test ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings ... à affiner cel1 = Mid(Target.Offset(0, 1), 2, 2) cel2 = Mid(Target.Offset(0, 1), 5, 2) 'Expliciter la Formule Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, Range(cel1).Value) _ , cel2, Range(cel2).Value) End If End Sub
A+
bonjour
heu non ca marche pas j ai l erreur 1004 la methode "range" de l'objet
"_Worksheet" a échoué
si tu as des compléments a faire je suis preneur
a+
th
"Carim" <carim007@yahoo.com> a écrit dans le message de groupe de discussion
: ae693a73-6ea5-4304-9914-ae431591d5aa@u10g2000prn.googlegroups.com...
Bonjour,
Juste une première étape test ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As String
Dim cel2 As String
If Not Intersect(Target, Range("e:e")) Is Nothing Then
Target.Offset(0, 1).Value = "'" & Target.Formula
'Extraction des Strings ... à affiner
cel1 = Mid(Target.Offset(0, 1), 2, 2)
cel2 = Mid(Target.Offset(0, 1), 5, 2)
'Expliciter la Formule
Target.Offset(0, 2).Value = "'" &
Application.WorksheetFunction.Substitute _
(Application.WorksheetFunction.Substitute(Target.Offset(0, 1),
cel1, Range(cel1).Value) _
, cel2, Range(cel2).Value)
End If
End Sub
heu non ca marche pas j ai l erreur 1004 la methode "range" de l'objet "_Worksheet" a échoué
si tu as des compléments a faire je suis preneur
a+ th
"Carim" a écrit dans le message de groupe de discussion :
Bonjour,
Juste une première étape test ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings ... à affiner cel1 = Mid(Target.Offset(0, 1), 2, 2) cel2 = Mid(Target.Offset(0, 1), 5, 2) 'Expliciter la Formule Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, Range(cel1).Value) _ , cel2, Range(cel2).Value) End If End Sub
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String Dim i As Integer Dim j As Integer Dim k As Integer Const Oper As String = "[*+-/]" If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings valable pour 2 éléments dans la formule j = Len(Target.Offset(0, 1)) For k = 1 To j If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then i = k Exit For End If Next k cel1 = Mid(Target.Offset(0, 1), 2, i - 2) cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _ Range(cel1).Value), cel2, Range(cel2).Value) End If End Sub
A +
Re ...
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As String
Dim cel2 As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Const Oper As String = "[*+-/]"
If Not Intersect(Target, Range("e:e")) Is Nothing Then
Target.Offset(0, 1).Value = "'" & Target.Formula
'Extraction des Strings valable pour 2 éléments dans la formule
j = Len(Target.Offset(0, 1))
For k = 1 To j
If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then
i = k
Exit For
End If
Next k
cel1 = Mid(Target.Offset(0, 1), 2, i - 2)
cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" &
Application.WorksheetFunction.Substitute _
(Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _
Range(cel1).Value), cel2, Range(cel2).Value)
End If
End Sub
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String Dim i As Integer Dim j As Integer Dim k As Integer Const Oper As String = "[*+-/]" If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings valable pour 2 éléments dans la formule j = Len(Target.Offset(0, 1)) For k = 1 To j If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then i = k Exit For End If Next k cel1 = Mid(Target.Offset(0, 1), 2, i - 2) cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _ Range(cel1).Value), cel2, Range(cel2).Value) End If End Sub
A +
titi
bonjour
oui merci cela fonctionne bien ! merci encore !
A bientot
A+ Th
"Carim" a écrit dans le message de groupe de discussion :
Re ...
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String Dim i As Integer Dim j As Integer Dim k As Integer Const Oper As String = "[*+-/]" If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings valable pour 2 éléments dans la formule j = Len(Target.Offset(0, 1)) For k = 1 To j If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then i = k Exit For End If Next k cel1 = Mid(Target.Offset(0, 1), 2, i - 2) cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _ Range(cel1).Value), cel2, Range(cel2).Value) End If End Sub
A +
bonjour
oui merci cela fonctionne bien !
merci encore !
A bientot
A+
Th
"Carim" <carim007@yahoo.com> a écrit dans le message de groupe de discussion
: 9fc6d31d-4a79-4d4b-a1c7-e6bd2bc96557@p69g2000hsa.googlegroups.com...
Re ...
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As String
Dim cel2 As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Const Oper As String = "[*+-/]"
If Not Intersect(Target, Range("e:e")) Is Nothing Then
Target.Offset(0, 1).Value = "'" & Target.Formula
'Extraction des Strings valable pour 2 éléments dans la formule
j = Len(Target.Offset(0, 1))
For k = 1 To j
If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then
i = k
Exit For
End If
Next k
cel1 = Mid(Target.Offset(0, 1), 2, i - 2)
cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" &
Application.WorksheetFunction.Substitute _
(Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _
Range(cel1).Value), cel2, Range(cel2).Value)
End If
End Sub
"Carim" a écrit dans le message de groupe de discussion :
Re ...
N'est valable que pour deux éléments dans la formule ...
Private Sub Worksheet_Change(ByVal Target As Range) Dim cel1 As String Dim cel2 As String Dim i As Integer Dim j As Integer Dim k As Integer Const Oper As String = "[*+-/]" If Not Intersect(Target, Range("e:e")) Is Nothing Then Target.Offset(0, 1).Value = "'" & Target.Formula 'Extraction des Strings valable pour 2 éléments dans la formule j = Len(Target.Offset(0, 1)) For k = 1 To j If Mid$(Target.Offset(0, 1).Value, k, 1) Like Oper Then i = k Exit For End If Next k cel1 = Mid(Target.Offset(0, 1), 2, i - 2) cel2 = Mid(Target.Offset(0, 1), i + 1, j - i)
Target.Offset(0, 2).Value = "'" & Application.WorksheetFunction.Substitute _ (Application.WorksheetFunction.Substitute(Target.Offset(0, 1), cel1, _ Range(cel1).Value), cel2, Range(cel2).Value) End If End Sub