VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

B

Bolak

XLDnaute Nouveau
Bonjour,

Voici mes 2 problèmes:

1- Tri, j'ai créé une macro pour effectuer 2 tris dans le premier onglet de mon fichier (Macro "Tri", voir pièce jointe) le hic est que la sélection est fixe selon cette macro mais elle variera d'une fois à l'autre selon l'information dans le tableau. ce qui sépare les 2 tri est la ligne vierge au centre de l'onglet importation qui est aussi alléatoire mais qui peut être identifié selon la date. (elle est jaune présentement mais c'est seulement pour vous la montrer). J'imagine que ce n'est pas une grosse modification à faire mais je ne sais pas par où commencer.

2- Une fois trié, j'aimerai que mon tableau ajoute des lignes tel que fait manuellement dans l'onglet "résultat souhaité". Soit selon la colonne B, ajouter une ligne et des sommes dans la colonne H et I immédiatement à la suite du dernier numéro identique de la colonne B. (voir couleur grise dans l'onglet résultat souhaité)
Autre contrainte, si à l'intérieur du même nombre de numéro identique de la colonne B il y a des numéros différents dans la colonne C il faudrait une somme séparée par numéro de la colonne C pour la colonne H. (voir couleur bleu dans onglet résultat souhaité)

Je suis débutant avec le VBA, j'ai fouillé dans recherche mais je n'arrive pas à me retrouver.

Merci d'avance à toute aide apporté, cela nous simplifiera la vie grandement!
 

Pièces jointes

  • Fichier envoi.xlsm
    32.1 KB · Affichages: 115
Dernière édition:
Trier par date Trier par votes
klin89

klin89

XLDnaute Accro
Re : VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

Bonsoir le forum,
Bonsoir Bolak,

Ce qui est compliqué, c'est de décrypter ta demande :rolleyes:
J'ai considéré que la feuille "Importation" était déjà triée par comparaison avec la feuille "Résultat souhaité"
Donc j'ai fait l'impasse sur le point 1.

Traitement du point 2 :
Exécute ces 2 macros successivement, la feuille active doit être la feuille "Importation"
Pour bien visualiser, les lignes insérées sont en vert soit les sous-totaux si j'ai bien compris.

VB: 
Sub InsererLignes()
Dim Lig As Long
Application.ScreenUpdating = False
Range("A" & Range("A65536").End(xlUp).Row + 1 & ":J" & Range("A65536").End(xlUp).Row + 1).Interior.ColorIndex = 43
For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
 If Range("B" & Lig - 1) <> "" Then
   If Range("B" & Lig) <> Range("B" & Lig - 1) Or Range("C" & Lig) <> Range("C" & Lig - 1) Then
     Range("A" & Lig).EntireRow.Insert
     Range("A" & Lig & ":J" & Lig).Interior.ColorIndex = 43
   End If
 End If
Next
Application.ScreenUpdating = False
End Sub

Traitement des données bloc par bloc :
VB: 
Sub Sous_Totaux_Par_Blocs()
dl = Range("A65536").End(xlUp).Row
x = 1
Do
    If Range("A" & x + 1) = "" Then
      y = Range("A" & x).Row
    Else
      y = Range("A" & x).End(xlDown).Row
    End If
    z = Range("A" & y).End(xlDown).Row
    w = z - y
    Range("B" & y + 1 & ":C" & y + 1).Value = Range("B" & y & ":C" & y).Value
    Range("G" & y + 1).Value = "Totaux"
    Range("H" & y + 1).Value = Application.Sum(Range("H" & x & ":H" & y))
    Range("I" & y + 1).Value = Application.Sum(Range("I" & x & ":I" & y))
    x = y + w
Loop Until x > dl
End Sub

Une variante :
VB: 
Sub Sous_Totaux_Par_Blocs()
dl = Range("A65536").End(xlUp).Row
x = 1: y = 1
Do
    Do Until Range("A" & y) = ""
      y = y + 1
    Loop
    z = Range("A" & y - 1).End(xlDown).Row
    w = z - y + 1
    Range("B" & y & ":C" & y).Value = Range("B" & y - 1 & ":C" & y - 1).Value
    Range("G" & y).Value = "Totaux"
    Range("H" & y).Formula = "=SUM(" & Range("H" & x).Address & ":" & Range("H" & y - 1).Address & ")"
    'Range("H" & y).Value = Application.Sum(Range("H" & x & ":H" & y - 1))
    Range("I" & y).Value = Application.Sum(Range("I" & x & ":I" & y - 1))
    x = y - 1 + w
    y = x
Loop Until x > dl
End Sub

J'ai un doute sur le calcul des sous-totaux en colonne I

Klin89
 
Dernière édition:
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

Bonjour le forum :)

Comme dit précédemment, j'ai revu les sous-totaux de la colonne I.
Pour que tu comprennes bien le déroulement du programme, j'ai procédé en 3 temps :
La feuille active doit être la feuille "Importation".

Insertion des lignes :
VB: 
Sub InsererLignes()
Dim Lig As Long
Application.ScreenUpdating = False
For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
 If Range("B" & Lig - 1) <> "" Then
   If Range("B" & Lig) <> Range("B" & Lig - 1) Or Range("C" & Lig) <> Range("C" & Lig - 1) Then
     Range("A" & Lig).EntireRow.Insert
     'Range("A" & Lig & ":J" & Lig).Interior.ColorIndex = 43
   End If
 End If
Next
Application.ScreenUpdating = False
End Sub

Sous-Totaux en colonne H :
VB: 
Sub Sous_Totaux_Par_Blocs_Colonne_H()
dl = Range("A65536").End(xlUp).Row
x = 1: y = 1
Do
    Do Until Range("A" & y) = ""
      y = y + 1
    Loop
    z = Range("A" & y - 1).End(xlDown).Row
    w = z - y + 1
    Range("G" & y).Value = "Totaux"
    With Range("B" & y & ":C" & y)
      .Value = Range("B" & y - 1 & ":C" & y - 1).Value
      .Interior.ColorIndex = 24
    End With
    With Range("H" & y)
      .Formula = "=SUM(" & Range("H" & x).Address & ":" & Range("H" & y - 1).Address & ")"
      .Interior.ColorIndex = 24
    End With
    x = y - 1 + w
    y = x
Loop Until x > dl
End Sub

Sous-Totaux en colonne I :
VB: 
Sub Sous_Totaux_Par_Blocs_Colonne_I()
dl = Range("A65536").End(xlUp).Row
x = 1: y = 1
Do
    Do Until Range("B" & y + 1) <> Range("B" & y)
      y = y + 1
    Loop
    z = Range("A" & y - 1).End(xlDown).Row
    w = z - y + 1
    Range("I" & y).Formula = "=SUM(" & Range("I" & x).Address & ":" & Range("I" & y - 1).Address & ")"
    Range("B" & y & ":C" & y).Interior.ColorIndex = 15
    Range("H" & y & ":I" & y).Interior.ColorIndex = 15
    x = y - 1 + w
    y = x
Loop Until x > dl
End Sub

A tester.

Klin89
 
Dernière édition:
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

Re Bolak,

Vois aussi cela :

VB: 
Sub InsererLignes()
Dim Lig As Long, DerLig As Long
Application.ScreenUpdating = False
DerLig = Range("A65536").End(xlUp).Row
With Range("B" & DerLig + 1 & ":C" & DerLig + 1)
  .Value = Range("B" & DerLig & ":C" & DerLig).Value
  .Interior.ColorIndex = 24
End With
Range("G" & DerLig + 1).Value = "Totaux"
Range("H" & DerLig + 1).Interior.ColorIndex = 24
For Lig = DerLig To 2 Step -1
 If Range("B" & Lig - 1) <> "" Then
   If Range("B" & Lig) <> Range("B" & Lig - 1) Or Range("C" & Lig) <> Range("C" & Lig - 1) Then
     Range("A" & Lig).EntireRow.Insert
     Range("G" & Lig).Value = "Totaux"
     With Range("B" & Lig & ":C" & Lig)
      .Value = Range("B" & Lig - 1 & ":C" & Lig - 1).Value
      .Interior.ColorIndex = 24
     End With
     Range("H" & Lig).Interior.ColorIndex = 24
  End If
 End If
Next
Application.ScreenUpdating = False
End Sub

VB: 
Sub Sous_Totaux_Par_Blocs_Colonne_H_I()
dl = Range("A65536").End(xlUp).Row
x = 1: y = 1: r = 1
Do
    Do Until Range("B" & y + 1) <> Range("B" & y)
      If Range("C" & y + 1) <> Range("C" & y) Then
        Range("H" & y).Formula = "=SUM(" & Range("H" & r).Address & ":" & Range("H" & y - 1).Address & ")"
        r = Range("H" & y + 1).Row
      End If
      y = y + 1
    Loop
    Range("H" & y).Formula = "=SUM(" & Range("H" & r).Address & ":" & Range("H" & y - 1).Address & ")"
    Range("I" & y).Formula = "=SUM(" & Range("I" & x).Address & ":" & Range("I" & y - 1).Address & ")"
    Union(Range("B" & y & ":C" & y), Range("H" & y & ":I" & y)).Interior.ColorIndex = 15
    z = Range("A" & y - 1).End(xlDown).Row
    w = z - y + 1: x = y - 1 + w
    y = x: r = x
Loop Until x > dl
End Sub

Bien évidemment à tester.

Edit : cela doit être bon, j'ai modifié le code ci-dessus post #6

Pour une macro de tri, vois ce lien :

https://www.excel-downloads.com/threads/macro-tri_range-sort.174117/

Klin89
 
Dernière édition:
Vote positif 0 Vote négatif
B

Bolak

XLDnaute Nouveau
Re : VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

Wow super! Merci Klin89.

De mon côté j'avais aussi avancé une solution, mais je vais essayer de l'adapter à la tienne pour garder ce qui est de mieux.

Pour mon 1er problème de tri, étant donné que les données n'auront pas le même nombre de ligne d'une fois à l'autre j'ai mis une variable qui fera un décompte du nombre de ligne:

Code: 
Dim fin1tri As Integer, fin2tri As Integer
'déterminer les fin de tri de la semaine 1 et 2 pour l'intervale
Range("A1").Select
fin1tri = Range(Selection, Selection.End(xlDown)).Count
Range("A" & fin1tri + 2).Select
fin2tri = Range(Selection, Selection.End(xlDown)).Count + fin1tri + 1
Range("A" & fin2tri).Select

    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Add Key:=Range("b1:b" & fin1tri), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Add Key:=Range("c1:c" & fin1tri), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Importation").Sort
        .SetRange Range("A1:K" & fin1tri)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Add Key:=Range("b" & fin1tri + 2 & ":b" & fin2tri), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Importation").Sort.SortFields.Add Key:=Range("c" & fin1tri + 2 & ":c" & fin2tri), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Importation").Sort
        .SetRange Range("A" & fin1tri + 2 & ":K" & fin2tri)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Pour ajouter les sommes par groupe d'employé, j'avais mis une boucle For mais avec un interval fixe de 800 boucles... Je vais corriger ceci...

Code: 
Dim ligne As Integer, interval1 As Integer, interval2 As Integer

Sheets("Importation").Select

For ligne = 1 To 800
    If Cells(ligne, 1).Value > 0 Then
        ' si le numero d'employé suivant est identique et le numero de tache aussi
        If Cells(ligne, 2).Value = Cells(ligne + 1, 2).Value And Cells(ligne, 3).Value = Cells(ligne + 1, 3).Value Then
            interval1 = interval1 + 1
        Else ' Si le numero suivant d'employé ou de tache n'est pas identique faire plus bas
            Cells(ligne + 1, 2).Select
            Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            ' ajouter somme colonne H selon le premier interval
            Cells(ligne + 1, 8).Select
            Range("h" & ligne + 1) = "=SUM(H" & ligne - interval1 & ":h" & ligne & ")/100"
            ' ajouter somme colonne I selon le premier interval
            Cells(ligne + 1, 9).Select
            Range("i" & ligne + 1) = "=SUM(i" & ligne - interval1 & ":i" & ligne & ")/100"
            'copie info col B et C
            Cells(ligne, 2).Select
            Selection.Copy
            Cells(ligne + 1, 2).Select ' B # employé
            ActiveSheet.Paste
            Cells(ligne, 3).Select
            Selection.Copy
            Cells(ligne + 1, 3).Select ' C # tache
            ActiveSheet.Paste
            Cells(ligne, 6).Select
            Selection.Copy
            Cells(ligne + 1, 6).Select ' F taux horaire
            ActiveCell.FormulaR1C1 = "=R[-1]C/100"
            Application.CutCopyMode = False
            ' reset interval
            interval1 = 0
        End If
    End If
Next ligne
        
End Sub

À force de lire le web, je commence à me débrouiller! :) Merci encore de ton aide.
 
Vote positif 0 Vote négatif
B

Bolak

XLDnaute Nouveau
Re : VBA Tri sur sélection variable et ajout de somme et ligne sur intervale variable

Rebonjour,

Suite à ce travail, est-ce possible de simplifier le code que j'ai à faire par la suite? En fait, je ne veux que copier mes sous-totaux dans une nouvelle feuille(copier en valeur), je le fais comme si je le ferais manuellement, il doit y avoir une autre façon moins longue que ça j'imagine?

Code: 
Sub E_exporation_interface()
Dim Ligneimp As Integer, Dl As Integer
Dim Ligneint As Integer
Dim valeurover As Double
Dim semaine As Integer
Ligneimp = 0
Ligneint = 0
semaine = 1
Dl = Range("B65536").End(xlUp).Row
Sheets("Importation").Select
For Ligneimp = 1 To Dl
    Sheets("Importation").Select
    If Cells(Ligneimp, 1).Value = 0 Then
    If Cells(Ligneimp, 2).Value > 0 Then
        Ligneint = Ligneint + 1
        Sheets("Importation").Select
        'copie colonne B importation # employé
        Cells(Ligneimp, 2).Copy
        Sheets("Interface").Select
        Cells(Ligneint, 2).Select
        ActiveSheet.Paste
        'copie colonne C importation # tache
        Sheets("Importation").Select
        Cells(Ligneimp, 3).Copy
        Sheets("Interface").Select
        Cells(Ligneint, 3).Select
        ActiveSheet.Paste
        'copie colonne F importation # taux
        Sheets("Importation").Select
        Cells(Ligneimp, 6).Copy
        Sheets("Interface").Select
        Cells(Ligneint, 7).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        'copie colonne H importation # heure regulière
        Sheets("Importation").Select
        Cells(Ligneimp, 8).Copy
        Sheets("Interface").Select
        Cells(Ligneint, 6).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Cells(Ligneint, 9).Value = semaine
        Sheets("Importation").Select
        If Cells(Ligneimp, 9) > 0 Then
            Ligneint = Ligneint + 1
            Sheets("Importation").Select
            'copie colonne B importation # employé
            Cells(Ligneimp, 2).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 2).Select
            ActiveSheet.Paste
            'copie colonne C importation # tache overtime
            Sheets("Interface").Select
            Cells(Ligneint, 3).Value = 43
            'copie colonne F importation # taux
            Sheets("Importation").Select
            Cells(Ligneimp, 6).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 7).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            'copie colonne I importation # heure regulière
            Sheets("Importation").Select
            Cells(Ligneimp, 9).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 30).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            'mettre colonne f interface les heures over
            Cells(Ligneint, 6).Value = Cells(Ligneint, 30).Value
            Cells(Ligneint, 9).Value = semaine
            'refaire une DEUXIÈME ligne pour soustraire du regulier
            Sheets("Importation").Select
            Ligneint = Ligneint + 1
            Sheets("Interface").Select
            'copie colonne B importation # employé
            Sheets("Importation").Select
            Cells(Ligneimp, 2).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 2).Select
            ActiveSheet.Paste
            'copie colonne C importation # tache
            Sheets("Importation").Select
            Cells(Ligneimp, 3).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 3).Select
            ActiveSheet.Paste
            'copie colonne F importation # taux
            Sheets("Importation").Select
            Cells(Ligneimp, 6).Copy
            Sheets("Interface").Select
            Cells(Ligneint, 7).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            'copie colonne I importation # heure regulière négatif
            Sheets("Importation").Select
            valeurover = -Cells(Ligneimp, 9).Value
            Sheets("Interface").Select
            Cells(Ligneint, 29).Value = valeurover
            'mettre colonne f interface les heures over
            Cells(Ligneint, 6).Value = Cells(Ligneint, 29).Value
            Cells(Ligneint, 9).Value = semaine
        End If
    Else: semaine = semaine + 1
    End If
    End If
Next Ligneimp
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

H
  • Question
Microsoft 365 Calcul d'une somme de données entre 2 dates (1 ancienne et aujourd'hui)
Réponses
13
Affichages
358
Heian911
H
A
  • Résolu(e)
XL 2016 Macros sur nom de fichier variable
Réponses
5
Affichages
415
oguruma
oguruma
A
  • Question
XL 2019 Tri plage + arrondis montants en VBA
Réponses
4
Affichages
342
Amilo
A
P
  • Question
Power Pivot Filtrer une somme en fonction de filtres sur un graphique
Réponses
2
Affichages
193
Pierre111
P
M
  • Question
Microsoft 365 Recopie ligne avec un code GOOGLE SHEET
Réponses
7
Affichages
185
Moreno076
M
G
  • Question
Microsoft 365 Choix et export de données (Résolu)
Réponses
4
Affichages
329
GClaire
G
Z
  • Question
Microsoft 365 Chemin pour atteindre le stockage cloud lors d'une génération de fichier Excel
Réponses
2
Affichages
265
zedude
Z
A
  • Question
XL 2019 Filtre avancé en VBA
Réponses
12
Affichages
325
Amilo
A
G
  • Question
Microsoft 365 Macro VBA - Excel
Réponses
12
Affichages
247
Dranreb
Dranreb
Akortys
  • Question
Microsoft 365 RESOLU - Macro - Recherche de lignes identiques et ressortir les lignes uniques
Réponses
2
Affichages
235
Akortys
Akortys

Membres actuellement en ligne

15 membres et 100 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 244
Messages
2 086 562
Membres
103 247
dernier inscrit
bottxok