Lorsque je tape ou modifie du texte dans plusieurs cellules il s'efface!!!

[un internaute]

Bonjour le forum,
Ligne N°2 et sur plusieurs colonnes (donc plusieurs cellules) et lorsque je tape ou modifie du texte et que je fait enter ou autre le texte s'efface.
Je ferme le fichier mais le texte n'est pas de "retour". Il faut repartir à zéro c'est à dire tout retaper.
Mais en dessous ligne N°3 j'ai des MFC.
Alors l'astuce c'est de remplir par double clic ou autre la ligne N°3 et après on fait ce que l'on veut avec le texte!!!
Mais si on n'y pense pas ça peut durer longtemps surtout si on le refait que dans 1 an!!!
Quelqu'un aurait-il eu ce souci et aurait-il une autre astuce?
Merci d'avance pour vos éventuels retours
Cordialement

 

[fanfan38]

Bonjour,
sans fichier c'est pas évident....
Est ce une macro qui se lance?
A+ François

 

[un internaute]

Bonjour,
sans fichier c'est pas évident....
Est ce une macro qui se lance?
A+ François

Bonsoir fanfan38,
Je fait des Double click sur cellules A3 C3 et B3 dans cet ordre.
Ça alimente ces cellules et ensuite je peux faire ce que je veux dans mon texte (Cellule A2 B2 C2 D2 E2 F2)
soit le taper ou le modifier.
Les Double Clic effectivement alimentent des macros.
Si je ne fait pas ça il s'en va et même si je ferme le fichier sans enregistrer le texte n'y est plus!!!
Merci à toi
A+ peut-être

 

[fanfan38]

Donc au lieu de faire une macro sur le double clic tu peux le faire sur change... (Sub Worksheet_Change(ByVal Target As Range))
tu peux aussi faire si target.row<>3 then exit sub
si(ou(target.column<>1; target.column<>3;target.column<>2) then exit sub...
Mais sur excel download tu ne trouveras personne qui te conseilleras sans fichier (à ce niveau)...
il serait plus approprié de faire une boite de saisie...
Si tu ne sauvegardes pas et que les changements sont gardés c'est que tu as un enregistrement automatique quand tu quittes....
A+ François

 

[un internaute]

Donc au lieu de faire une macro sur le double clic tu peux le faire sur change... (Sub Worksheet_Change(ByVal Target As Range))
tu peux aussi faire si target.row<>3 then exit sub
si(ou(target.column<>1; target.column<>3;target.column<>2) then exit sub...
Mais sur excel download tu ne trouveras personne qui te conseilleras sans fichier (à ce niveau)...
il serait plus approprié de faire une boite de saisie...
Si tu ne sauvegardes pas et que les changements sont gardés c'est que tu as un enregistrement automatique quand tu quittes....
A+ François

Ah! chapeau François.
ça => (Sub Worksheet_Change(ByVal Target As Range)) => déjà fait.
Avec => target.row<>3 then exit sub => c'est bon.
Ma ligne était la suivante : If Target.Count > 1 Then Exit Sub

 

[un internaute]

Bonjour François et à tous,
J'ai crié victoire trop tôt.
A+
Bonne journée
Voici mon module actuel:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ligne
Dim NbInr As Integer, NbLigne As Long
Dim Cel As Range

If Target.Count > 1 Then Exit Sub
InitTOTO
If Not Intersect(Range("C3:C" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
If UCase(Target) <> "TOTO" Then
Range("A" & Target.Row & ":C102").ClearContents
Ligne = Range("E" & Rows.Count).End(xlUp).Row
Range("E" & Ligne & ",G" & Ligne & ":H" & Ligne) = ""
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = NbGoutte
Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Range("A" & Target.Row)
Target = "TOTO"

Range("B" & Target.Row + 1 & ":C102").ClearContents
NbInr = Application.CountIf(Range("C3:C102"), "TOTO")
If NbInr = 1 Then
Ligne = Target.Row
If Ligne > 3 Then
Range("A3:C" & Ligne - 1).Delete shift:=xlShiftUp
End If
Range("A3:C3").AutoFill Destination:=Range("A3:C102"), Type:=xlFillSeries
Range("B4:C102").ClearContents
ElseIf NbInr = 5 Then
For Ligne = 4 To Target.Row
If UCase(Range("C" & Ligne)) = "TOTO" Then
Range("A3:C" & Ligne - 1).Delete shift:=xlShiftUp
Exit For
End If
Next Ligne
Ligne = Target.Row
Range("A" & Ligne & ":C" & Ligne).AutoFill Destination:=Range("A" & Ligne & ":C102"), Type:=xlFillSeries
Range("B" & Ligne + 1 & ":C102").ClearContents
End If
ElseIf Not Intersect(Range("B3:B" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
Application.EnableEvents = False
NbLigne = 103 - Target.Row
If NbLigne > 1 Then Range("B" & Target.Row).AutoFill Destination:=Range("B" & Target.Row).Resize(Application.Min(NbJour, NbLigne))
If Target = NbGoutte And Target.Offset(0, 1) = "TOTO" Then
Range("H" & Rows.Count).End(xlUp).Offset(1, 0) = DateAdd("d", NbJour - 1, Range("A" & Target.Row))
End If
End If
Init_Feuilles
Application.EnableEvents = True
End Sub

 

[un internaute]

Bonjour François et à tous,
J'ai crié victoire trop tôt.
A+
Bonne journée
Voici mon module actuel:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ligne
Dim NbInr As Integer, NbLigne As Long
Dim Cel As Range

If Target.Count > 1 Then Exit Sub
InitTOTO
If Not Intersect(Range("C3:C" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
If UCase(Target) <> "TOTO" Then
Range("A" & Target.Row & ":C102").ClearContents
Ligne = Range("E" & Rows.Count).End(xlUp).Row
Range("E" & Ligne & ",G" & Ligne & ":H" & Ligne) = ""
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = NbGoutte
Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Range("A" & Target.Row)
Target = "TOTO"

Range("B" & Target.Row + 1 & ":C102").ClearContents
NbInr = Application.CountIf(Range("C3:C102"), "TOTO")
If NbInr = 1 Then
Ligne = Target.Row
If Ligne > 3 Then
Range("A3:C" & Ligne - 1).Delete shift:=xlShiftUp
End If
Range("A3:C3").AutoFill Destination:=Range("A3:C102"), Type:=xlFillSeries
Range("B4:C102").ClearContents
ElseIf NbInr = 5 Then
For Ligne = 4 To Target.Row
If UCase(Range("C" & Ligne)) = "TOTO" Then
Range("A3:C" & Ligne - 1).Delete shift:=xlShiftUp
Exit For
End If
Next Ligne
Ligne = Target.Row
Range("A" & Ligne & ":C" & Ligne).AutoFill Destination:=Range("A" & Ligne & ":C102"), Type:=xlFillSeries
Range("B" & Ligne + 1 & ":C102").ClearContents
End If
ElseIf Not Intersect(Range("B3:B" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
Application.EnableEvents = False
NbLigne = 103 - Target.Row
If NbLigne > 1 Then Range("B" & Target.Row).AutoFill Destination:=Range("B" & Target.Row).Resize(Application.Min(NbJour, NbLigne))
If Target = NbGoutte And Target.Offset(0, 1) = "TOTO" Then
Range("H" & Rows.Count).End(xlUp).Offset(1, 0) = DateAdd("d", NbJour - 1, Range("A" & Target.Row))
End If
End If
Init_Feuilles
Application.EnableEvents = True
End Sub

Bonjour le forum,
Si on faisait une Msgbox du style "Si on tape ou modifie du texte de la cellule A2 à C2 Double Cliquez sur Cellule A3 Avant"
Mais où le mettre?
Merci d'avance
Cordialement

Macro à modifier:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
InitAZYTER 'Module posologie
If Target.Column = 1 Then Target.Value = Date: Cancel = True
If Not Intersect(Range("C3:C" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
Cancel = True
If Range("A" & Target.Row) = "" Then
MsgBox "Afficher la Date Colonne A"
Exit Sub
End If
Target = IIf(Target = "TOTO", "", "TOTO")
ElseIf Not Intersect(Range("B3:B" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
Cancel = True
Target = IIf(Target = NbGoutte, "", NbGoutte)
End If
End Sub