Partie d'un code VBA qui ne fonctionne plus + copie tableur

Le 02/10/2024 à 12:42

Bonjour à toutes et à tous,

Je suis encore novice dans le codage, j'apprends de manière autodidacte en fonction de mes besoins. Donc tout ce que je fais est bien entendu très bancale. Je m'en excuse.

Par rapport à ce code (développé par une personne de ce forum), une partie ne fonctionne plus. C'est a dire que lorsque je clique sur "terminé", la ligne va se copier dans l'onglet archivage adéquat, mais ne se supprime pas du tableau.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nLigCAR As Long
Dim avData As Variant
Dim nLigArch As Long
   On Error GoTo Fin_WsC
   Application.EnableEvents = False
   If Not Application.Intersect(Target, ActiveSheet.ListObjects("TVISITES").ListColumns(TSCAR_COL_STATUTV).DataBodyRange) Is Nothing Then
      nLigCAR = Target.Row - Target.ListObject.Range.Row
      ActiveSheet.ListObjects("TVISITES").ListColumns(TSCAR_COL_STATUTV_HD).DataBodyRange(nLigCAR) = Now
      If Target.Value = TSCAR_STATUT_TERMINE Then
         avData = Target.ListObject.ListRows(nLigCAR).Range
         With Worksheets("Archive V").ListObjects("TARCHIVAGE_V")
            nLigArch = .ListRows.Add.Index
            .ListRows(nLigArch).Range = avData
         End With
         Target.ListObject.ListRows(nLigCAR).Delete
      End If
   ElseIf Not Application.Intersect(Target, ActiveSheet.ListObjects("TVISITES").ListColumns(TSCAR_COL_MOTIFV).DataBodyRange) Is Nothing Then
      nLigCAR = Target.Row - Target.ListObject.Range.Row
      ActiveSheet.ListObjects("TVISITES").ListColumns(TSCAR_COL_MOTIFV_HD).DataBodyRange(nLigCAR) = Now
   End If
Fin_WsC:
   On Error GoTo 0
   Application.EnableEvents = True
   Exit Sub
End Sub

Il fonctionne avec la 2ème partie Module (partie "visite") suivant :

Option Explicit
' Cas à suivre
Public Const TSCAR_COL_MOTIF = "Motif du dossier à suivre"
Public Const TSCAR_COL_MOTIF_HD = "Date de l'encodage du motif"
Public Const TSCAR_COL_STATUT = "Statut du dossier à suivre"
Public Const TSCAR_COL_STATUT_HD = "Date de l'encodage du statut"

' Visite
Public Const TSCAR_COL_MOTIFV = "Motif de la demande de visite"
Public Const TSCAR_COL_MOTIFV_HD = "Date de la demande de visite"
Public Const TSCAR_COL_STATUTV = "Statut du dossier de visite"
Public Const TSCAR_COL_STATUTV_HD = "Date de l'encodage du statut visite"

' Valeur du statut Terminé.
Public Const TSCAR_STATUT_TERMINE = "Terminé"

C'est très embêtant car j'ai un autre onglet qui possède le même code, mais qui fait référence à la partie supérieure du module (cas à suivre) et qui fonctionne très bien ! Voici le code de cette feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nLigCAR As Long
Dim avData As Variant
Dim nLigArch As Long
   On Error GoTo Fin_WsC
   Application.EnableEvents = False
   If Not Application.Intersect(Target, ActiveSheet.ListObjects("TCAS_A_REVOIR").ListColumns(TSCAR_COL_STATUT).DataBodyRange) Is Nothing Then
      nLigCAR = Target.Row - Target.ListObject.Range.Row
      ActiveSheet.ListObjects("TCAS_A_REVOIR").ListColumns(TSCAR_COL_STATUT_HD).DataBodyRange(nLigCAR) = Now
      If Target.Value = TSCAR_STATUT_TERMINE Then
         avData = Target.ListObject.ListRows(nLigCAR).Range
         With Worksheets("Archive CàR").ListObjects("TARCHIVAGE_CaR")
            nLigArch = .ListRows.Add.Index
            .ListRows(nLigArch).Range = avData
         End With
         Target.ListObject.ListRows(nLigCAR).Delete
      End If
   ElseIf Not Application.Intersect(Target, ActiveSheet.ListObjects("TCAS_A_REVOIR").ListColumns(TSCAR_COL_MOTIF).DataBodyRange) Is Nothing Then
      nLigCAR = Target.Row - Target.ListObject.Range.Row
      ActiveSheet.ListObjects("TCAS_A_REVOIR").ListColumns(TSCAR_COL_MOTIF_HD).DataBodyRange(nLigCAR) = Now
   End If
Fin_WsC:
   On Error GoTo 0
   Application.EnableEvents = True
   Exit Sub
End Sub

Si quelqu'un peu m'éclairer...

Egalement, je me demandais, pourquoi lorsque je copie un tableau Excel, dans le nouveau fichier copier, le code VBA ne fonctionne plus? Bien qu'il soit présent dans l'éditeur.

Merci et excellente journée.

Le 02/10/2024 à 14:21

bonjour cecegc,

ce "On Error GoTo Fin_WsC" vous embête pour voir où la macro fait son erreur, donc à mon avis, c'est quelque chose à éviter.

2eme point, je n'aime pas la construction "target.listobject.ListObject.ListRows(nLigCAR).Delete"

un moment

Le 02/10/2024 à 14:38

Bonjour,

Sans voir le fichier...

juste avant cette ligne

Target.ListObject.ListRows(nLigCAR).Delete

Ne fusse que pour voir si la ligne est bien connue, mettez cette ligne et relancez le code

msgbox nLigCAR

NB : la ligne delete est bizarre ...

Crdlt

Edit : oups bsalv, je n'avais vérifié qu'il y avait une réponse. Je vous laisse continuer sur ce fil

Le 02/10/2024 à 15:05

Le tableur comporte des données sensibles, je travaille dans l'administration. J'aurai peur d'en oublier en tentant de les supprimer. Désolé, je ne vous facilite pas le travail.

Merci pour vos réactions, j'attends donc des éclaircissements de Dan, mais j'ai bien un pop up qui s'ouvre avec le chiffre 8 qui s'affiche lorsque je relance le code.

Edit : Des nouvelles de Bsalv, pardon !

Le 02/10/2024 à 15:08

Merci pour vos réactions, j'attends donc des éclaircissements de Dan, mais j'ai bien un pop up qui s'ouvre avec le chiffre 8 qui s'affiche lorsque je relance le code.

BsAlv va revenir vers vous

En attendant, vous pouvez aussi remplacer le .DELETE par .SELECT, afin de vérifier que la ligne 8 à supprimer est bien sélectionnée

Le 02/10/2024 à 17:07

re, salut Dan,

sorry, j'avais un intervention ....

voici ma proposition (sans fichier, donc c'est une supposition)

et la seule chose à faire quand vous copier votre tableau, c'est changer son nom et eventuellement le nom des colonnes ...

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim nLigCAR As Long, LO1, LO2, iSect As Range, c, iOffset

     Set LO1 = Me.ListObjects("TVISITES")    'tableau source
     Set LO2 = Worksheets("Archive V").ListObjects("TARCHIVAGE_V")     'tableau "archive"

     Application.EnableEvents = False

     With LO1
          Set iSect = Intersect(Target, .ListColumns(TSCAR_COL_STATUTV).DataBodyRange)     'ces cellules modifiées dans cette colonne
          If Not iSect Is Nothing Then
               For Each c In iSect.Cells     'boucler ces cellules modifiées
                    nLigCAR = c.Row - LO1.Range.Row     'n° listrow
                    .ListColumns(TSCAR_COL_STATUTV_HD).DataBodyRange(nLigCAR, 1).Value = Now
                    If c.Value = TSCAR_STATUT_TERMINE Then
                         LO2.ListRows.Add.Range.Value = .ListRows(nLigCAR).Range.Value
                         .ListRows(nLigArch).Delete
                    End If
               Next
          Else
               Set iSect = Intersect(Target, .ListColumns(TSCAR_COL_MOTIFV).DataBodyRange)     'ces cellules modifiées dans cette colonne
               If Not iSect Is Nothing Then
                    iOffset = .ListColumns(TSCAR_COL_MOTIFV_HD).Index - .ListColumns(TSCAR_COL_MOTIFV).Index
                    For Each c In iSect.Cells     'boucler ces cellules modifiées
                         c.Offset(, iOffset).Value = Now     'mettre à jour cette autre colonne
                    Next
               End If
          End If
     End With

     Application.EnableEvents = True

End Sub
Rechercher des sujets similaires à "partie code vba qui fonctionne copie tableur"