Code remonte et descente bug avec soustotal

Le 28/11/2013 à 06:54

bonjour a vous tous

pour faire suite a https://forum.excel-pratique.com/excel/insertion-d-un-sous-total-t44614.html merveilleusement animé par H2so4

je voudrais que maintenant les codes qui sont derrière les boutons qui font remonter où descendre une ligne, puisse reprendre leur fonction qui est mis en défaut par l'ajout de sous total

les codes effacent la ligne du sous total et laisse une ligne vide de plus le code pour remonter change le format de la col c où est la tranche en défusionnant la ligne , je joint un fichier exemple qui devrai fonctionner sans sa base

https://www.cjoint.com/c/CKBxmyR8Z9K

Pascal

Le 28/11/2013 à 14:11

bonjour,

code adapté, à tester

Option Explicit

Public Chemin As String, nomfichier As String, feuille As String

       Sub Remonter_Ligne()
              Dim T(), NoLigne As Long, S As Double, H As Double
              Dim DerLig As Long, Ok As Boolean, ActLigne As Long

              'Feuil1 est le nom de la propriété de l'objet "Feuille" visible
              'dans la fenêtre de l'éditeur de code et non le nom de l'onglet
              'de la feuille.
              'With Feuil1
              With Worksheets("facture")
                'Trouve la dernière ligne occupée dans les colonnes c:h
                DerLig = .Range("C:H").Find(What:="*", _
                                            LookIn:=xlFormulas, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlPrevious).Row
                'Si ton tableau était vide, la dernière ligne serait
                'la première ligne de ton tableau.
                If DerLig < 19 Then DerLig = 19
              End With

              'Si l'usager a sélectionné une cellule dans la plage C19:Cx
              If Not Intersect(ActiveCell, Range("C19:H" & DerLig)) Is Nothing Then
                'Une variable pour le numéro de ligne
                NoLigne = ActiveCell.Row
                On Error Resume Next
                If Cells(NoLigne, "G") <> "" Then Exit Sub
                If Cells(NoLigne - 1, "G") Then Exit Sub 'si colonne G <>"" (ligne sous-total) on ne fait rien
                On Error GoTo 0
                'Si la ligne sélectionnées est en caractère grand et fusionnée
                If Range("C" & NoLigne).MergeCells = True And Range("C" & NoLigne).Font.Bold = True Then
                  'On remonte d'une ligne
                  ActiveCell.offset(-1).Select
                  'On met fin à l'opération
                  Exit Sub
                End If
                'si la ligne active est 19, fin des opérations
                'car on ne peut pas remonter plus haut
                If ActiveCell.Row = 19 Then Exit Sub
                'une petite boucle afin de trouver la ligne aus-dessus de la ligne
                'Active qui ne soit pas fusionnée et en caractère gras.
                Do
                  NoLigne = NoLigne - 1
                  If Range("C" & NoLigne).MergeCells <> True Then 'And _Range("C" & NoLigne).Font.Bold <> True Then
                    'Si le critère est respecter, sortie de la boucle
                    Ok = True
                    Exit Do
                  End If
                Loop Until NoLigne = 19
                'Une deuxième variable pour le numéro de la ligne de la cellule active.
                ActLigne = ActiveCell.Row
                'Au sortir de la boucle, si tout est Ok
                If Ok = True Then
                  'met dans une variable tableau, le contenu de la ligne
                  T = Rows(NoLigne).Cells.Value
                  'met dans S la hauteur de la ligne active
                  S = Rows(ActLigne).Height
                  'met en H la hauteur de la ligne où sera copiée les données
                  H = Rows(NoLigne).Height
                  'Copie de la ligne active vers la ligne au-dessus
                   Rows(NoLigne).Value = Rows(ActLigne).Value

                  'Mise à jour des formules ligne NoLigne
                  Range("L" & NoLigne).Formula = "=$I" & NoLigne & "*$K" & NoLigne
                  'partie en dessous bon mais pas encore fonctionnelle (je cherche pourquoi)
                  Range("o" & NoLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
                  Range("P" & NoLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"

                  'Copie des valeurs de T dans la ligne active
                  Rows(ActLigne) = T
                  'Nouvelle hauteur de la ligne de la ligne active s'il y a lieu
                  Rows(ActLigne).RowHeight = H
                  'Nouvelle hauteur de la ligne de la ligne au-dessus s'il y a lieu.
                  Rows(NoLigne).RowHeight = S

                 'Mise à jour des formules ligne ActLigne
                  Range("L" & ActLigne).Formula = "=$I" & ActLigne & "*$K" & ActLigne
                  Range("o" & ActLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
                  Range("P" & ActLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"
                'sélection de la ligne où ont été copiées les données
                  Rows(NoLigne).Cells(1, 4).Select
                End If
              End If
            End Sub

Sub Descendre_Ligne()
   Dim T(), NoLigne As Long, S As Double, H As Double
      Dim DerLig As Long, Ok As Boolean, ActLigne As Long

      'Feuil1 est le nom de la propriété de l'objet "Feuille" visible
      'dans la fenêtre de l'éditeur de code et non le nom de l'onglet
      'de la feuille.
      'With Feuil1
      With Worksheets("facture")
        'Trouve la dernière ligne occupée dans les colonnes c:h
        DerLig = .Range("C:H").Find(What:="*", _
                                    LookIn:=xlFormulas, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlPrevious).Row
        'Si ton tableau était vide, la dernière ligne serait
        'la première ligne de ton tableau.
        If DerLig < 19 Then DerLig = 19
      End With

      'Si l'usager a sélectionné une cellule dans la plage C19:Cx
      If Not Intersect(ActiveCell, Range("C19:H" & DerLig)) Is Nothing Then
        'Une variable pour le numéro de ligne
        NoLigne = ActiveCell.Row
        On Error Resume Next
        If Cells(NoLigne, "G") <> "" Then Exit Sub
        If Cells(NoLigne + 1, "G") Then Exit Sub 'si colonne G <>"" (ligne sous-total) on ne fait rien
        On Error GoTo 0
        'Si la ligne sélectionnées est en caractère grand et fusionnée
        If Range("C" & NoLigne).MergeCells = True And Range("C" & NoLigne).Font.Bold = True Then
          'On remonte d'une ligne
          ActiveCell.offset(1).Select
          'On met fin à l'opération
          Exit Sub
        End If
        'si la ligne active est 19, fin des opérations
        'car on ne peut pas remonter plus haut
        If ActiveCell.Row = 19 Then Exit Sub
        'une petite boucle afin de trouver la ligne aus-dessus de la ligne
        'Active qui ne soit pas fusionnée et en caractère gras.
        Do
          NoLigne = NoLigne + 1
          If Range("C" & NoLigne).MergeCells <> True Then 'And _Range("C" & NoLigne).Font.Bold <> True Then
            'Si le critère est respecter, sortie de la boucle
            Ok = True
            Exit Do
          End If
        Loop Until NoLigne = 19
                'Une deuxième variable pour le numéro de la ligne de la cellule active.
                ActLigne = ActiveCell.Row
                'Au sortir de la boucle, si tout est Ok
                If Ok = True Then
                  'met dans une variable tableau, le contenu de la ligne
                  T = Rows(NoLigne).Cells.Value
                  'met dans S la hauteur de la ligne active
                  S = Rows(ActLigne).Height
                  'met en H la hauteur de la ligne où sera copiée les données
                  H = Rows(NoLigne).Height
                  'Copie de la ligne active vers la ligne au-dessus
                   Rows(NoLigne).Value = Rows(ActLigne).Value

                  'Mise à jour des formules ligne NoLigne
                  Range("L" & NoLigne).Formula = "=$I" & NoLigne & "*$K" & NoLigne
                  'partie en dessous bon mais pas encore fonctionnelle (je cherche pourquoi)
                  Range("o" & NoLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
                  Range("P" & NoLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"

                  'Copie des valeurs de T dans la ligne active
                  Rows(ActLigne) = T
                  'Nouvelle hauteur de la ligne de la ligne active s'il y a lieu
                  Rows(ActLigne).RowHeight = H
                  'Nouvelle hauteur de la ligne de la ligne au-dessus s'il y a lieu.
                  Rows(NoLigne).RowHeight = S

                 'Mise à jour des formules ligne ActLigne
                  Range("L" & ActLigne).Formula = "=$I" & ActLigne & "*$K" & ActLigne
                  Range("o" & ActLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
                  Range("P" & ActLigne).Select
                  ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"
                'sélection de la ligne où ont été copiées les données
                  Rows(NoLigne).Cells(1, 4).Select
                End If
              End If
End Sub
Le 29/11/2013 à 20:52

bonsoir h2s04

Merci beaucoup de ta réponse,

mais la remontée d'une ligne passe au dessus du sous total mais en modifiant les formats mis dans chaque cellules et ce jusqu'en haut, et bizarrement si je descends le même article à son point de départ, le code de descente rétabli les formats.

Pascal

Le 29/11/2013 à 23:35
grisan29 a écrit :

bonsoir h2s04

Merci beaucoup de ta réponse,

mais la remontée d'une ligne passe au dessus du sous total mais en modifiant les formats mis dans chaque cellules et ce jusqu'en haut, et bizarrement si je descends le même article à son point de départ, le code de descente rétabli les formats.

Pascal

peut-être que le plus simple est de supprimer la ligne sous-total avant de lancer ta macro.

Le 30/11/2013 à 07:53

bonjour h2so4

h2so4 à écrit

peut-être que le plus simple est de supprimer la ligne sous-total avant de lancer ta macro.

c'est une solution qui ne me vas pas question perte de temps pour tout recommencer surtout quand il faut modifier le devis

Pascal

Rechercher des sujets similaires à "code remonte descente bug soustotal"