Code remonte et descente bug avec soustotal
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
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
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
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.
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