Insertion ligne - sous-totaux - Total

[thespeedy20]

Bonjour,

Une petite aide serait la bien bien venue....
Dans mon fichier ci-Joint, une macro insère une ligne à 50 et 100... j'ai un sous-total à 50(ligne de 1 à 49) mais je n'arrive à avoir le sous-total à 100 (ligne 51 à 99).... +sous-total des 101 à 104... et pour finir en ligne 110 le total des colonnes B - C - D - E.

Puis-je avoir une aide de la part des experts de ce forum

Merci d'avance

Oli

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Bonjour thespeedy20,

Voyez le fichier joint et cette macro :

Sub SousTotaux()
Dim pas&, nvide&, ncol%, t, rest(), soustotal(), total(), i&, n&, j%
pas = 49 'à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
'---initialisation---
With [A1].CurrentRegion
  ncol = IIf(.Columns.Count < 2, 2, .Columns.Count) 'au moins 2 cellules
  t = .Resize(, ncol) 'matrice, plus rapide
  ReDim rest(1 To .Rows.Count + Int(.Rows.Count / pas) + nvide + 2, 1 To ncol)
End With
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
For i = 1 To UBound(t)
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
    If IsNumeric(t(i, j)) Then _
      soustotal(j) = soustotal(j) + t(i, j): total(j) = total(j) + t(i, j)
  Next j
  If i Mod pas = 0 Then
    n = n + 1
    rest(n, 1) = "Sous-total"
    For j = 2 To ncol
      rest(n, j) = soustotal(j)
    Next j
    ReDim soustotal(1 To ncol) 'RAZ
  End If
Next i
'---les 2 dernières lignes du tableau rest---
If rest(n, 1) <> "Sous-total" Then
  n = n + 1
  rest(n, 1) = "Sous-total"
  For j = 2 To ncol
    rest(n, j) = soustotal(j)
  Next j
End If
n = n + nvide + 1
rest(n, 1) = "Total"
For j = 2 To ncol
  rest(n, j) = total(j)
Next j
'---restitution---
With [K1] 'à adapter
  .Resize(UBound(rest), ncol) = rest
  .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents
End With
End Sub

Elle est très rapide car elle utilise des tableaux VBA.

Bonne soirée.

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Re,

S'agissant de mois, il paraît logique de faire les sous-totaux par année :

Sub SousTotaux()
Dim dest As Range, nvide&, ncol%, t, i&, n&, rest(), soustotal(), total(), j%
Set dest = [L1] 'cellule de destination, à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
'---initialisation---
Application.ScreenUpdating = False
dest.CurrentRegion.EntireColumn.ClearContents 'RAZ
With [A1].CurrentRegion
  If .Rows.Count = 1 Then Exit Sub 'si le tableau est vide
  dest.Resize(.Rows.Count, .Columns.Count) = .Value 'copie des valeurs
End With
With dest.CurrentRegion
  .Sort dest(1, 2), xlAscending, Header:=xlYes 'tri sur les années
  ncol = IIf(.Columns.Count < 2, 2, .Columns.Count) 'au moins 2 colonnes
  t = .Resize(.Rows.Count + 1, ncol) 'matrice, plus rapide
End With
'---nombre d'années/sous-totaux---
For i = 2 To UBound(t) - 1
  If t(i + 1, 2) <> t(i, 2) Then n = n + 1
Next
'---dimensions des tableaux---
ReDim rest(1 To UBound(t) + n + nvide, 1 To ncol)
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
n = 0
For i = 2 To UBound(t) - 1
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
    If j > 2 And IsNumeric(t(i, j)) Then _
      soustotal(j) = soustotal(j) + t(i, j): total(j) = total(j) + t(i, j)
  Next j
  If t(i + 1, 2) <> t(i, 2) Then
    n = n + 1
    rest(n, 1) = "Sous-total": rest(n, 2) = t(i, 2)
    For j = 3 To ncol
      rest(n, j) = soustotal(j)
    Next j
    ReDim soustotal(1 To ncol) 'RAZ
  End If
Next i
'---dernière ligne du tableau rest---
n = n + nvide + 1
rest(n, 1) = "Total"
For j = 3 To ncol
  rest(n, j) = total(j)
Next j
'---restitution---
dest(2).Resize(n, ncol) = rest
End Sub

Fichier (2).

Bonne nuit.

 

[Lone-wolf]

Re : Insertion ligne - sous-totaux - Total

I job,

toi aussi pas encore sous la couette?


Allez bonne nuit


Amicalement Lone-wolf

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Bonjour thespeedy20, Lone-wolf, le forum,

Perso je préfère mettre des dates en colonne A ce qui facilite le tri du 1er tableau.

Edit : j'ai modifié la macro pour que l'on puisse mettre [A1] comme cellule de destination :

Sub SousTotaux()
Dim dest As Range, nvide&, ncol%, t, i&, n&, rest(), soustotal(), total(), j%
Set dest = [K1] 'cellule de destination, à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
'---initialisation---
Application.ScreenUpdating = False
With [A1].CurrentRegion
  If .Rows.Count > 1 Then _
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri sur les dates
  ncol = .Columns.Count
  t = .Resize(.Rows.Count + 1, ncol) 'matrice, plus rapide
  dest.EntireColumn.Resize(, ncol) = "" 'RAZ
  dest.Resize(, ncol) = Application.Index(t, 1, 0) 'titres
  If .Rows.Count = 1 Then Exit Sub
End With
'---nombre d'années/sous-totaux---
For i = 2 To UBound(t) - 1
  If Val(t(i + 1, 1)) = 0 Then t(i + 1, 1) = 0
  If Val(t(i, 1)) Then _
    If Year(t(i + 1, 1)) <> Year(t(i, 1)) Then n = n + 1
Next i '---dimensions des tableaux---
ReDim rest(1 To UBound(t) + n + nvide, 1 To ncol)
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
n = 0
For i = 2 To UBound(t) - 1
  If Val(t(i, 1)) Then
    n = n + 1
    For j = 1 To ncol
      rest(n, j) = t(i, j)
      If IsNumeric(t(i, j)) Then _
        soustotal(j) = soustotal(j) + t(i, j): total(j) = total(j) + t(i, j)
    Next j
    If Year(t(i + 1, 1)) <> Year(t(i, 1)) Then
      n = n + 1
      rest(n, 1) = "Sous-total " & Year(t(i, 1))
      For j = 2 To ncol
        rest(n, j) = soustotal(j)
      Next j
      ReDim soustotal(1 To ncol) 'RAZ
    End If
  End If
Next i
'---dernière ligne du tableau rest---
n = n + nvide + 1
rest(n, 1) = "Total"
For j = 2 To ncol
  rest(n, j) = total(j)
Next j
'---restitution---
dest(2).Resize(n, ncol) = rest
End Sub

Fichiers (3) et (3 bis).

Bonne journée.

 

[thespeedy20]

Re : Insertion ligne - sous-totaux - Total

Bonjour Job75,

Tout d'abord , grand merci pour le temps consacré pour ce projet, il correspond parfaitement à mes attentes.... Merci

Puis-je te soumettre un autre cas: ici également sous-totaux, toutes les 30 lignes...mais ici c'est le nombre de cours dans la col C, E et G et dans les col D, F, H c'est le sous-total des montants entre parenthèse...ex f2(2)....et sur la dernière ligne total général. ci-joint le fichier

Je te remercie par avance

Bonne journée

Oli

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Re,

Je viens de modifier la macro du post #5 pour que [A1] puisse être la cellule de destination.

Pour ce qui est de votre dernier fichier je n'ai pas compris ce que vous voulez calculer.

A+

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Re,

Bon d'accord, j'ai juste adapté la macro du post #2.

Dans le code de la feuille "Sous-totaux" :

Private Sub Worksheet_Activate()
Dim pas&, nvide&, ncol%, ntitres&, t, rest(), soustotal(), total(), i&, n&, j%, v
pas = 30 'à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
ncol = 8 'nombre de colonnes
ntitres = 2 'nombre de lignes de titres
'---initialisation---
With Feuil1.[A1].CurrentRegion 'CodeName
  t = .Resize(, ncol) 'matrice, plus rapide
  ReDim rest(1 To .Rows.Count + Int(.Rows.Count / pas) + nvide + 2, 1 To ncol)
End With
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
For i = ntitres + 1 To UBound(t)
  n = n + 1
  For j = 1 To ncol
    v = t(i, j)
    If v <> "" Then
      rest(n, j) = v
      If j > 2 Then
        If j Mod 2 Then
          soustotal(j) = soustotal(j) + 1 'colonnes C E G
        Else
          soustotal(j) = soustotal(j) + Val(Mid(v, InStr(v, "(") + 1)) 'colonnes D F H
        End If
      End If
    End If
  Next j
  If (i - ntitres) Mod pas = 0 Then
    n = n + 1
    rest(n, 2) = "Sous-total"
    For j = 3 To ncol
      rest(n, j) = soustotal(j)
      total(j) = total(j) + soustotal(j)
    Next j
    ReDim soustotal(1 To ncol) 'RAZ
  End If
Next i
'---les 2 dernières lignes du tableau rest---
If n Then
  If rest(n, 2) <> "Sous-total" Then
    n = n + 1
    rest(n, 2) = "Sous-total"
    For j = 3 To ncol
      rest(n, j) = soustotal(j)
      total(j) = total(j) + soustotal(j)
    Next j
  End If
End If
n = n + nvide + 1
rest(n, 2) = "Total"
For j = 3 To ncol
  rest(n, j) = total(j)
Next j
'---restitution---
With [A3] 'à adapter
  .Resize(n, ncol) = rest
  .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents
End With
With Me.UsedRange: End With 'actualise la barre de défilement
End Sub

La macro s'exécute quand on active la feuille.

Fichier joint.

Edit 1 : si vous voulez colorer les colonnes il suffit de modifier la MFC.

Dans le fichier (1 bis) il y a des bordures et couleurs sur toutes les lignes de la plage B:H.

La MFC les efface quand la ligne est vide.

Edit 2 : j'avais oublié de comptabiliser les colonnes C E G.

A+

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Bonjour thespeedy20, le forum,

Sur Win 8 - Excel 2013 j'ai testé avec un tableau de 61100 lignes.

La macro s'exécute en 1,2 seconde.

Bonne journée.

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Bonjour thespeedy20, le forum,

Une solution avec restitution dans la feuille "Cours" elle-même.

Vu la rapidité de la macro, si le nombre de lignes ne dépasse pas quelques milliers, on peut utiliser une macro Worksheet_Change :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pas&, nvide&, ncol%, ntitres&, lig&, t, rest(), soustotal(), total(), i&, n&, j%, v
pas = 30 'à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
ncol = 8 'nombre de colonnes
ntitres = 2 'nombre de lignes de titres
lig = ntitres + 1 '1ère ligne
Application.EnableEvents = False 'désactive les évènements
'---initialisation---
With [A1].CurrentRegion
  'sécurité si l'on efface une ligne entière
  If Application.CountA(Target(1).EntireRow.Resize(, ncol)) = 0 Then _
    If MsgBox("Toutes les lignes après la ligne " & .Rows.Count & " seront supprimées." _
      & vbLf & "Voulez-vous continuer ?", 4) = 7 Then Application.Undo: GoTo 1
  t = .Resize(, ncol) 'matrice, plus rapide
  ReDim rest(1 To .Rows.Count + Int(.Rows.Count / pas) + nvide + 2, 1 To ncol)
End With
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
For i = lig To UBound(t)
  If InStr(LCase(t(i, 2)), "total") = 0 Then
    n = n + 1
    For j = 1 To ncol
      v = t(i, j)
      If v <> "" Then
        rest(n, j) = v
        If j > 2 Then
          If j Mod 2 Then
            soustotal(j) = soustotal(j) + 1 'colonnes C E G
          Else
            soustotal(j) = soustotal(j) + Val(Mid(v, InStr(v, "(") + 1)) 'colonnes D F H
          End If
        End If
      End If
    Next j
    If (lig - ntitres) Mod pas = 0 Then
      n = n + 1
      rest(n, 2) = "Sous-total"
      For j = 3 To ncol
        rest(n, j) = soustotal(j)
        total(j) = total(j) + soustotal(j)
      Next j
      ReDim soustotal(1 To ncol) 'RAZ
    End If
    lig = lig + 1
  End If
Next i
'---les 2 dernières lignes du tableau rest---
If n Then
  If rest(n, 2) <> "Sous-total" Then
    n = n + 1
    rest(n, 2) = "Sous-total"
    For j = 3 To ncol
      rest(n, j) = soustotal(j)
      total(j) = total(j) + soustotal(j)
    Next j
  End If
End If
n = n + nvide + 1
rest(n, 2) = "Total"
For j = 3 To ncol
  rest(n, j) = total(j)
Next j
'---restitution---
With Cells(ntitres + 1, 1)
  .Resize(n, ncol) = rest
  .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents
End With
With Me.UsedRange: End With 'actualise la barre de défilement
1 Application.EnableEvents = True 'réactive les évènements
End Sub

Fichiers (2) et (2 bis).

Remarques :

1. Si l'on essaie de modifier ou supprimer une ligne "Sous-Total" ou "Total" elle est intégralement restituée.

2. Du fait qu'on utilise CurrentRegion, si l'on efface une ligne entière toutes les lignes situées dessous sont effacées, d'où le message de sécurité au début.

A+

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Re,

On peut aussi utiliser un bouton pour afficher/masquer les sous-totaux et le total.

Edit : le message de sécurité est ici en cellule C1.

Fichiers (3) et (3 bis).

A+

 

[thespeedy20]

Re : Insertion ligne - sous-totaux - Total

Bonjour Job75,

Félicitations pour cet excellent travail...je peux encore abuser de ta bonté ? dans le calcul des cours, ici un exemple :

ALEGBE Maxim CHANT D'ENSEMBLE
FORMATION MUSICALE
GUITARE
GUITARE D'ACCOMPAGNEMENT

suit 4 cours mais compte que pour 1, est- il possible de changer la formule(sous-totaux)Peut-être partir d'une numérotation automatique...et pour les degrés un simple comptage (pas les chiffres entre parenthèse...)... Je te remercie vivement pour tout ce travail qui me fera gagner un temps précieux dans mon travail....et tu auras traiter ainsi tout les cas de figure...

Merci, Merci

Olivier.

 

[job75]

Re : Insertion ligne - sous-totaux - Total

Re Olivier,

J'avais bien dit au post #7 que je n'avais pas compris ce qu'il fallait compter

Maintenant le comptage en colonnes C E G est bien sûr assez compliqué.

Surtout il ne fallait pas hésiter à incrémenter (provisoirement) le pas pour ne pas couper un nom au milieu de ses cours :

Private Sub CommandButton1_Click()
Dim pas&, nvide&, ncol%, ntitres&, pasplus&, affiche As Boolean
Dim t, nlig&, rest(), soustotal(), total(), i&, num&, n&, j%, v, test As Boolean
pas = 30 'à adapter
nvide = 3 'nombre de lignes vides en fin de tableau, à adapter
ncol = 8 'nombre de colonnes
ntitres = 3 'nombre de lignes de titres
pasplus = pas 'pour incrémentation
'---initialisation---
CommandButton1.Width = [A1:B1].Width
affiche = CommandButton1.Caption Like "Affiche*"
CommandButton1.Caption = IIf(affiche, "Masquer", "Afficher") & " les sous-totaux"
With [A1].CurrentRegion
  t = .Resize(, ncol) 'matrice, plus rapide
  nlig = .Rows.Count
  ReDim rest(1 To nlig + Int(nlig / pas) + nvide + 2, 1 To ncol)
End With
ReDim soustotal(1 To ncol)
ReDim total(1 To ncol)
'---remplissage du tableau rest---
For i = ntitres + 1 To nlig
  If InStr(LCase(t(i, 2)), "total") = 0 Then
    num = num + 1
    n = n + 1
    For j = 1 To ncol
      v = t(i, j)
      If v <> "" Then
        rest(n, j) = v
        If j > 2 Then
          If j Mod 2 Then 'colonnes C E G
            test = False
            test = t(i, 2) <> ""
            If i > 1 Then test = test Or t(i - 1, j) = ""
            If i = ntitres + 1 Or test Then soustotal(j) = soustotal(j) + 1
          Else 'colonnes D F H
            soustotal(j) = soustotal(j) + 1
          End If
        End If
      End If
    Next j
    If affiche And num = pasplus Then
      If i < nlig Then If t(i + 1, 2) = "" Then pasplus = pasplus + 1: GoTo 1
      n = n + 1
      rest(n, 2) = "Sous-total"
      For j = 3 To ncol
        rest(n, j) = soustotal(j)
        total(j) = total(j) + soustotal(j)
      Next j
      ReDim soustotal(1 To ncol) 'RAZ
      pasplus = pas: num = 0
    End If
  End If
1 Next i
'---les 2 dernières lignes du tableau rest---
If affiche Then
  If n Then
    If rest(n, 2) <> "Sous-total" Then
      n = n + 1
      rest(n, 2) = "Sous-total"
      For j = 3 To ncol
        rest(n, j) = soustotal(j)
        total(j) = total(j) + soustotal(j)
      Next j
    End If
  End If
  n = n + nvide + 1
  rest(n, 2) = "Total"
  For j = 3 To ncol
    rest(n, j) = total(j)
  Next j
End If
'---restitution---
With Cells(ntitres + 1, 1)
  If n Then .Resize(n, ncol) = rest
  .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents
End With
With Me.UsedRange: End With 'actualise la barre de défilement
End Sub

Fichiers (4) et (4 bis) avec le bouton.

Si vous vouliez utiliser les fichiers (1) ou (2) dites-le, la modification de la macro serait facile.

A+

 

[thespeedy20]

Re : Insertion ligne - sous-totaux - Total

re, Job75,

Merci pour ta rapidité, on va utiliser le fichier 4 bis. Est il possible de remettre la ligne 2 et 3 après chaque sous-total ? sauf pour le dernier bien évidemment...Petite question, si je remplaçais toutes les données par des autres , la macro fonctionnerait-elle ?

Encore merci Job75 pour toute l'aide qui tu m'apportes...

Olivier

 

[thespeedy20]

Re : Insertion ligne - sous-totaux - Total

Re,

Les données sont brutes...en colonnes, il faut les remettre dans les domaines concernés. et bien sur le nom + prénom de l'élève ne doive apparaître qu'une fois comme dans le fichier par ordre alphabétique.

Bien à toi

Olivier