L'écriture texte sur ligne A2 colonnes A B C s'efface

Le 19/08/2017 à 07:06

Bonjour le forum,

Lorsque je tape ou modifie du texte comme indiqué dans le sujet ça efface le texte.

Même si je ne fait pas enregistrer il est effacé définitivement. Il faut le retaper.

Mais j'ai des MFC dans la ligne A3 et colonnes A B C

Pour contourner le problème j''alimente par Double clic les cellules A3 B3 C3 et le tour est joué.

Ces cellules étant alimentées je peux taper ou modifier du texte

Quelqu'un aurait-il une solution autre car lorsque je remets ces cellules à zéro j'oublie toujours d'alimenter les cellules A3 B3 C3?

Merci pour vos éventuels retours

Cordialement

Voici ma macro ci-dessous:

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

Le 19/08/2017 à 08:03

Bonjour toutes et tous

un message box signalant sur la feuille en question

Merci de remplir les celulles A3, B3, C3

comme cela certain de remplir les champs

crdlt

André

Le 19/08/2017 à 08:11

Bonjour à tous

al87 a écrit :

L'écriture texte sur ligne A2 colonnes A B C s'efface

et encore :
al87 a écrit :

Mais j'ai des MFC dans la ligne A3 et colonnes A B C

A2, comme A3, n'est pas une ligne mais une cellule.

Du coup, je ne comprends rien à tes explications.

Désolé...

Bye !

Le 19/08/2017 à 08:15

Bonjour gmb,

Oui des cellules je l'ai dit dans l'explication.

Cordialement

Le 19/08/2017 à 08:21

Bonjour,

Indente ton code pour qu'il soit plus facile à lire.

Il manque deux Sub et donc on ne peut pas savoir se qui se passe. Si "InitTOTO" fait des changements dans la feuille, la procédure évènementielle est à nouveau appelée.

Dans le code, il te faut déplacer le gel des évènements avant le bloc :

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

car il peut y avoir modifs dans la feuille qui appellent à nouveau la proc "Change()" et selon ce que fait la Sub "InitTOTO", il serait même bien de déplacer avant cette dernière le gel des évènements.

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 '<--- elle fait quoi cette Sub ?

    If Not Intersect(Range("C3:C" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then

        'il faut déplacer l'instruction du gel des évènements ici...
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        '...car le code va générer un nouvel appel de la procédure évènementielle puisqu'il efface les valeurs donc, changements (ClearContents)
        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 '<--- et celle là aussi, elle fait quoi ?
    Application.EnableEvents = True

End Sub
Le 19/08/2017 à 08:35
Theze a écrit :

Bonjour,

Indente ton code pour qu'il soit plus facile à lire.

Il manque deux Sub et donc on ne peut pas savoir se qui se passe. Si "InitTOTO" fait des changements dans la feuille, la procédure évènementielle est à nouveau appelée.

Dans le code, il te faut déplacer le gel des évènements avant le bloc :

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

car il peut y avoir modifs dans la feuille qui appellent à nouveau la proc "Change()" et selon ce que fait la Sub "InitTOTO", il serait même bien de déplacer avant cette dernière le gel des évènements.

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 '<--- elle fait quoi cette Sub ?

    If Not Intersect(Range("C3:C" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then

        'il faut déplacer l'instruction du gel des évènements ici...
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        '...car le code va générer un nouvel appel de la procédure évènementielle puisqu'il efface les valeurs donc, changements (ClearContents)
        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 '<--- et celle là aussi, elle fait quoi ?
    Application.EnableEvents = True

End Sub

Bonjour Theze,

Tu as raison mais impossible à expliquer sans le fichier.

Et le fichier est très très personnel.

Je te remercie mais l'idée d'un message est interressante.

Mais le mettre où dans mon code?

Là est le problème.

Merci beaucoup à tous

Cordialement

Rechercher des sujets similaires à "ecriture texte ligne colonnes efface"