Microsoft 365 Petit problème ajout ligne à un tableau

Mathieu35190 à dit:

Bonjour

Je rencontre une petite difficulté d'ans l'exécution d'une Macro.

Pour info la plus grosse partie du code je l'ai récupérée. Elle n'est pas exactement comme je la voudrais évidement.

C'est une macro pour gérer des cartes de fidélités

J'ai une première page avec ma liste de client et un bouton dans lequel j'ajoute les dépenses qu'il à réalisés
j'ai le montant de référence qui me permet de déclencher un message pour m'informer que le client à atteint sa remise de 10€

sur la seconde page j'ai la liste des dépenses de tous mes clients dans un tableau

mon problème est que quand j'applique la macro j'ai bien la première ligne qui s'ajoute a mon tableau mais la seconde (le reste) s'inscrit toujours en dessous du tableau ce qui me ruine mes formule ensuite quand je reprends les données pour autre chose

voici le sc VBA en question:

VB:

Sub AjoutAchat()
  Dim NbFois As Integer, NbAvtR As Integer
  Dim DLigA As Long, IdClt As String, Lig As Long
  Dim MaForm As String, Rng1 As String, Rng2 As String, Rng3 As String
  Dim TotalFois As Integer
  ' Initialiser les variables
  LigSel = Selection.Row
  TotalFois = 0
  NbAvtR = Sheets("BdDClt").Range("NbAchtAvtR").Value
  '
  ' Tester le numéro de ligne
  If LigSel <= 2 Then
    ' Si ligne d'entête on prévient et on sort
    MsgBox "Merci de sélectionner une ligne de client et non d'entête", vbInformation, "ATTENTION .."
    Exit Sub
  End If
  '
  ' Mémoriser l'IdClient
  IdClt = Range("A" & LigSel).Value
  '
  ' Tester si une ligne avec un nom de client a été sélectionnée
  If Len(Range("B" & LigSel).Value) = 0 Then
    ' Si aucun nom de client sur la ligne
    MsgBox "Merci de sélectionner une ligne avec un nom de client", vbInformation, "ATTENTION ..."
    Exit Sub
  End If
  '
  ' Si OK, afficher l'Userform pour la saisie
  UsF_Achat.Show
  '
  ' Définir la feuille qui reçoit les achats
  Set ShtA = Worksheets("Achats")
  ' Calculer le nombre d'€ dépensé
  DLigA = ShtA.Range("A" & Rows.Count).End(xlUp).Row
  Rng1 = "(" & ShtA.Name & "!A2:A" & DLigA & "=""" & IdClt & """)"  ' Id Client
  Rng2 = "(" & ShtA.Name & "!E2:E" & DLigA & "="""")"  ' Remise non effectuée
  Rng3 = "(" & ShtA.Name & "!D2:D" & DLigA & ")"  ' Nombre de €
  MaForm = Rng1 & "*" & Rng2 & "*" & Rng3
  On Error Resume Next
  NbFois = 0: NbFois = Application.Evaluate("SUMPRODUCT(" & MaForm & ")")
  On Error GoTo 0
  ' Si le nombre d € que le client a dépensé est inférieur à NbAchtAvtR
  If NbFois >= NbAvtR Then
    ' Afficher le message
    MsgBox "Le client à droit à 10€ de remise", vbInformation, "REMISE ACCORDEE"
    ' Pour chaque ligne de la feuille Achat
    For Lig = 2 To DLigA
      ' Si l'IdClient est le bon
      If ShtA.Range("A" & Lig).Value = IdClt Then
        ' Si la colonne de [Remise faite] est vide
        If ShtA.Range("E" & Lig).Value = "" Then
          ' On fait l'addition du nombre de d €
          TotalFois = TotalFois + ShtA.Range("D" & Lig).Value
         
          ' On vérifie que le total ne dépasse pas le NbAchtAvtR
          If TotalFois > NbAvtR Then
            ' Sinon on recopie la ligne en dessous
            ShtA.Rows(Lig).Copy
            ShtA.Rows(Lig + 1).Insert shift:=xlDown
            ' On inscrit le nombre d € pour arriver à NbAchtAvtR sur la première ligne
            ShtA.Range("D" & Lig).Value = ShtA.Range("D" & Lig).Value - (TotalFois - NbAvtR)
            ' On inscrit le nombre d € restant pour la prochaine fois sur la ligne suivante
            ShtA.Range("D" & Lig + 1).Value = TotalFois - NbAvtR
                       
          End If
          ' On complète
          ShtA.Range("E" & Lig).Value = "OK"
        End If
      End If
    Next Lig
  End If
End Sub

Quelqu'un serait-il m'expliquer pourquoi ma première entrée ajoute bien une ligne a mon tableau mais pas la seconde?

Merci d'avance pour votre aide

Cordialement

Cliquez pour agrandir...