creer des sous totaux en VBA

**facteur** · 26/03/2008, 22h41

Je travaille, chaque jour, sur un tableau excel avec des filtres atomatiques.
Sur le filtre, de la colonne A, je selectionne le dernier crtitere et je cree des sous totaux de la colonne de la clonne B a la colonne E.
Je souhaiterais automatiser cette tache mais j'ai deux soucis :
*la cellule ou est creer le sous totale n'est jamais la meme d'un jour sur l'autre
*le nom du derniere critere de la colonne A peut etre different d'un jour sur l'autre

je m'en remet a vous pour trouver une solution

Merci d'avance

Madjid

**Le Pierre** · 26/03/2008, 23h22

bonjour

places tes sous totaux juste au dessus de ton tableau (en A1, A2, ...)

dans chaque cellule utilise la fonction : SOUS.TOTAL(no_fonction;réf1;réf2;...) avec no_fonction = 9 pour la somme

seules les cellules visibles sont totalisées.

tu aurais par exemple en A1 : SOUS.TOTAL(9;A3:A65536)

à plus

**facteur** · 31/03/2008, 22h50

Salut Pierre,

Merci pour ta reponse, mais j'aurais aime inserer dans ma maco la formule des sous totaux avec une variable "a" qui correspondrait au numero de la derniere ligne de la colonne A de mon tableau excel ( en effet, d'un jour a l'autre, mon tableau n'a jamais le meme nombre de ligne). Ainsi comme formule se sous totaux j'aurais une formule du style:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[a]C:R[-3]C)"

Cette formule serait ensuite inserer dans la deuxieme cellule vide de la colonne H.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range("H2").End(xlDown).Offset(2, 0).Select

Serais tu me donner la formule VBA qui permet de trouver le numero de la dernier ligne non vide de la colonne A d'un tableau excel>

Merci par avance Pierre

**Abed_H** · 31/03/2008, 23h31

Envoyé par facteur

Serais tu me donner la formule VBA qui permet de trouver le numero de la dernier ligne non vide de la colonne A d'un tableau excel>

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ligne = Cells(Rows.Count, "A").End(xlUp).Row

Bonne chance

Abed_H

**Le Pierre** · 01/04/2008, 13h07

bonjour

le code d'Abed_H est parfait.
tu pourrais prendre ceci pour utiliser la variable N° de ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub test()
    LigFin = Cells(Rows.Count, "A").End(xlUp).Row
    LigDeb = 2
    Cells(1, 1).Select
    ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[" & LigDeb & "]C:R[" & LigFin - 1 & "]C)"
End Sub

à plus

**facteur** · 01/04/2008, 20h37

merci énormément pour tous ces infos.

je les teste et vous envoie une réponse.

A plus pierre et Abed

**facteur** · 02/04/2008, 00h07

J'ai essayer la macro de Pierre, et cela me marche pas. Du moins, la macro marche tres bien mais cela m'affiche un sous total erronne.
Voici un tableau joins dans ce message pour expliquer mon probleme (tableau compose de 4 colonne et 24 ligne) .
la colonne A correspond a la liste de departement
la colonne B;C et D correspond a des quantites

Lorsque j'applique ma macro avec les astuce fournie par Pierre et Abed, j'obtiens la macro suivante

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub soustotaux()
    LigFin = Cells(Rows.Count, "A").End(xlUp).Row
    LigDeb = 2
    'Cells(1, 1).Select j'ai supprimer cette ligne car inutile pour la macro
    Range("B2").End(xlDown).Offset(2,0).Select 
    ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[" & LigDeb & "]C:R[" & LigFin - 1 & "]C)"
End Sub

Le sous total s'affiche bien sur la deuxieme cellule vide de la colonne B (B26) mais avec un sous total (9,B26:B28) alors qu'il devrait etre (9,B2:B24).
D'ou vient le probleme.

J'en profite pour demander si on pouvait ameliorer la formule des sous totaux en recuperant non pas la derniere ligne non vide de la colonne A mais l'avant derniere ligne.
Ainsi le sous total serait (9,B2:B23)

Merci de votre aide

**Le Pierre** · 02/04/2008, 22h22

bonjour

Effectivement il y a plusieurs conditions qui empêchent le fonctionnement :

- le sous total doit se trouver dans la première ligne du tableau pour que la formule fonctionne et de plus lorsque tu réalises un filtre le sous total reste visible car autrement il est masqué
- le code "LigFin = Cells(Rows.Count, "A").End(xlUp).Row" ne fonctionne pas correctement car il y a d'autres données dessous ton tableau et la valeur de LigFin est donc supérieure au nombre de lignes recherché
- j'ai inséré une ligne blanche entre tes données et la ligne total pour éviter qu'il soit intégrer au sous total (est-ce que ce total est utile ?)

j'ai rectifié ton tableau et le code pour que ça fonctionne (voir fichier joint)

j'espère que tu y veras plus clair avec la pièce jointe. N'hésites pas à me recontacter.
Cordialement.

**facteur** · 03/04/2008, 00h31

Merci pour cette reponse tres rapide mais je vais encore t'embeter (

).
Pour etre explicite je te joins une copie du tableau sur lequel je travaille chaque jour (je precise que le nombre de ligne du tableau est aleatoire d'un jour a l'autre).

Si je transpose ta macro sur ce tableau; cela cree quelques desagrements:
'Les intitules dans les cellules B1, C1, D1 ont disparu au profit de la formule des sous totaux.
'les sous totaux qui s'affichent partent de la ligne 3 jusqu'a la fin de la colonne: cela donne (9,A3:A65535) alors que j'aimerais que le sous total aille de la ligne 2 jusqu'a la derniere ligne de la colonne A

Ainsi, serais t il possible d'apporter encore quelques modification a ta superbe macro: *Si le sous total doit etre obligatoirement etre affiche sur la premiere ligne du tableau, il faudrait alors que la formule s'affiche UNIQUEMENT au dessus de la cellule H1(CP660) et etre recopiejusqu'au dessus de la cellule R1 (taux de remplissage...). Le sous total ne doit pas s'afficher au dessus des cellules A1 a G1.
* La formule du sous total devrait etre du style (9, 2ieme ligne du tableau: derniere ligne de la colonne A).
Dernier ligne de la colonne A , ceci afin d'eviter que la ligne du total soit inserer dans la formule des sous totaux .

PS: Le tableau joint a deja subit une macro afin d'etre dans cette configuration. Est ce que le fait de rajouter une ligne supplementaire au dessus du tableau (pour l'insertion du sous total) peut fausser la macro deja en place.

Et merci encore pour toutes ces reponses Pierre !!!!!!!!

**Le Pierre** · 03/04/2008, 10h52

bonjour

voici le programme modifié.
Tu remarqueras que la procédure débute par l'insertion d'une première ligne afin d'y placer les sous totaux.

J'ai vu qu'il y a une liaison avec une autre feuille. Si tu veux rompre cette liaison tu peux utiliser la commande :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ActiveWorkbook.BreakLink Name:="D:\Tmp\matrice.xls", Type:=xlExcelLinks

(obtenue avec l'enregistreur de macro : Edition --> Liaisons --> rompre)

à plus

**facteur** · 04/04/2008, 00h24

Avec le tableau que je t'ai envoye, ta macro fonctionne a merveille.
Mais des que je l'ai insere a la suite de ma macro, cela me donne un sous total errone : (9, H2:H3) au lieu de (9,H3:H136).

.
Pour ce qui concerne la mise en page : cela est tres bien (j'ai insere la formule des sous totaux jusqu'a la cellule S1).

Pierre , pourrais tu analyser ce probleme des sous totaux. Pour cela, je t'envoie mon tableau ("depart") tel que je l'extraie lorsque je travaille dessus.
Ma macro (MacroHermes2) est associee au tableau.
Pourrais tu me dire pourquoi ta macro ne fonctionne pas lorsqu'elle est integre dans ma macro.

Pierre pourrais tu aussi m'expliquer en quelques ligne cette synthaxe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
procedureLig = 3
    Do
       x = Cells(Lig, 1).Value
        If x = "" Then Exit Do
        Lig = Lig + 1
    Loop
    LigFin = Lig - 1
    LigDeb = 2
    Cells(1, 1).Select

Et encore merci pour ta patience et ton savoir

.

PS: Pour la liaison avec l'autre feuille , je t'ai envoye cette feuille ("matrice"). Mais cela n'a pas d'importance car cette feuille n'a pas d'impact sur la formule des sous totaux.
Facteur

**Le Pierre** · 04/04/2008, 14h41

bonjour

je vais regarder tes tableaux pour identifier le problème et je te tiendrai au courant

pour ce qui est de la procédure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
Lig = 3
Do
       x = Cells(Lig, 1).Value
        If x = "" Then Exit Do
        Lig = Lig + 1
Loop
LigFin = Lig - 1

c'est une boucle conditionnelle qui permet de tester si une cellule contient une valeur quelconque
si cellule vide (if x="" then exit do) on quitte la boucle Do ... Loop
si cellule non vide on incrémente le N° de ligne (Lig) et on continue le test
le test débute à partir de la cellule : ligne 3, colonne 1 et s'arrête à la première cellule vide rencontrée dans la colonne 1
en sortie de boucle le N° de la dernière ligne non vide est égal à Lig-1 puisque la cellule en Lig,1 est vide.

à plus tard

**Le Pierre** · 04/04/2008, 19h10

bonsoir

j'ai pu regarder ton fichier et voici la correction.

le problème venait de la recherche dans la colonne 1 contenant des valeurs #N/A considérées comme vide
ce #N/A vient de valeurs non trouvées dans matrice.xls

j'ai modifié le code pour compter les lignes de la colonne 2 (au lieu de la 1) et en déduisant une ligne supplémentaire à cause de l'indication "total" en fin de données.
j'ai testé et ça marche : le calcul du sous total est correct
Lors de la première utilisation il faudra peut-être préciser l'emplacement de ton fichier matrice.xls (2 fois).
j'ai ajouté aussi une ligne de code pour désactiver la mise à jour de l'écran pendant le déroulement du programme (ça fait moins mal aux yeux)

à plus

**will-1981** · 04/04/2008, 19h38

bonjour

Je ne suis pas très bon en VB mais je peux te donner une macro qui fonctionne super bien car elle me permet d'avoir un total semaine par semaine.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Private Sub sstotaux(ecrisla, nosemaine)
topdepart = ecrisla - 1
 
'reperage du bloc à calculer
For z = ecrisla - 1 To 5 Step -1
If Cells(z, 1) = "" Then
topdepart = z
Exit For
End If
Next
 
'calcul des ss totaux
For z = topdepart To ecrisla - 1
 
If nosemaine = Cells(z, 1) Then
    Rows(z).Select
    Selection.Font.ColorIndex = 5
End If
Cells(ecrisla, 8) = Cells(ecrisla, 8) + Cells(z, 8)
Cells(ecrisla, 12) = Cells(ecrisla, 12) + Cells(z, 12)
Next
Cells(ecrisla, 7) = "Total S" & Cells(ecrisla - 1, 1)
    Rows(ecrisla).Select
If nosemaine = Cells(ecrisla - 1, 1) Then
    Selection.Font.ColorIndex = 5
End If
    Selection.Font.Bold = True
Cells(ecrisla, 1).Select
End Sub

Si ça t'aide c'est avec plaisir,
Will

**facteur** · 05/04/2008, 00h06

BRAVO et encore BRAVO !!!!!!

je ne sais comment te remercier.

Et merci pour ces renseignement sur cette boucle (tres interessant ): il est vrai que je les utilise jamais .

Pierre , Ne verrais tu pas d'inconvients que tu sois dans ma liste d'amis

.

Passe un agreable week end Pierre.

Envoyé par Le Pierre

bonsoir

j'ai pu regarder ton fichier et voici la correction.

le problème venait de la recherche dans la colonne 1 contenant des valeurs #N/A considérées comme vide
ce #N/A vient de valeurs non trouvées dans matrice.xls

j'ai modifié le code pour compter les lignes de la colonne 2 (au lieu de la 1) et en déduisant une ligne supplémentaire à cause de l'indication "total" en fin de données.
j'ai testé et ça marche : le calcul du sous total est correct
Lors de la première utilisation il faudra peut-être préciser l'emplacement de ton fichier matrice.xls (2 fois).
j'ai ajouté aussi une ligne de code pour désactiver la mise à jour de l'écran pendant le déroulement du programme (ça fait moins mal aux yeux)

à plus

**Le Pierre** · 05/04/2008, 17h06

bonjour

Pas de problème pour figurer dans ta liste.
Content de t'avoir rendu service
à plus

**facteur** · 15/04/2008, 00h25

Me revoila pour t'embeter

Cela concerne toujours ma macro.
Je voudrais developper le critere retard qui se situe dans la colonne S du tableau qui se trouve dans le fichier "depart".
Pour cela, j'ai cree un autre fichier intitule "analyse retard 2008". Et j'ai affecte une macro qui permet d'extraire les lignes en retard du fichier "depart" et de les copier sur le tableau du fichier "analyse retard 2008".

Mais j'ai un soucis :
j'ai insere dans le fichier "depart" une date situee dans la cellule A1( cette date provient du tableau original avant l'activation de la macroHERMES).
Et Le fichier ou se trouve le tableau "depart" est nomme differemment d'un jour a l'autre.
j'aimerais copier en meme temps , a partir du fichier "depart"
* la date, situe dans la cellule A1 sur la cellule A2 du fichier "analyse retard" et
* la plage de cellules allant de B3 a T118 sur la cellule B2 du fichier "analyse retard 2008".

Si je demande le copiement simutane c'est que le fichier "depart " change de nom d'un jour sur l'autre .Par consequent je ne peux pas le nommer sur ma macro pour pourvoir effectuer des copies successives .

Voila a quoi ressemble cette macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub retard()
'
    Dim b As Integer ' b correspond a la derniere ligne du tableau
    Cells.Select
    ActiveSheet.ShowAllData
    Selection.AutoFilter Field:=19, Criteria1:="1"
    b = Range("b" & Range("b65353").End(xlUp).Row).Row ' formule pour recuperer le N° de la dernière ligne du tableau
    Range("A3:T" & b).Select ' selection du tableau allant de la cellule B3 a la derniere cellule de la colonne T
    Selection.Copy
    'ouvrir le fichier "analyse retard 2008"
    Workbooks.Open Filename:="C:\Documents and Settings\GHEMMAZI Hayette\Desktop\analyse retard 2008.xls"
    Range("B1").Select
    If Range("B2").Value <> "" Then Range("B1").End(xlDown).Select 'Si la cellule B2 n'est pas vide,
    'on selectionne la derniere cellule vnon vide de la colonne A. Si A2 est libre, la derniere cellule non vide est A1.
    'Il n'est pas necesaire de se deplacer.
    ActiveCell.Offset(1, 0).Select 'On selectionne la cellule situee une ligne en dessous de la cellule active.
    'Enfait, on se positionne sur la premiere ligne vide de la feuille "analyse retard 2008".
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' on copie le tableau
    'selectionner a partir de la premiere ligne  vide de la feuille "analyse retard 2008
    Application.CutCopyMode = False 'instrcution qui permet d'effacer la marque de selection autor de la plage copiee
 
 
End Sub

PS: je te joins le fichier "depart "ou se trouve la macro retard
et le fichier "analyse retard 2008".
je te joins egalement le fichier "matrice" en cas ou la macro te demanderais d'actualiser les donnees

Et c'est reparti pour un casse tete

**Le Pierre** · 15/04/2008, 10h49

bonjour

voici le code modifié :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub retard()
'
    Dim b As Integer ' b correspond a la derniere ligne du tableau
    Dim DateEnCours As Date
 
    Application.ScreenUpdating = False 'la mise à jour de l'écran est désactivée
    Cells.Select
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    DateEnCours = Cells(1, 1).Value
 
    Selection.AutoFilter Field:=19, Criteria1:="1"
    b = Range("b" & Range("b65353").End(xlUp).Row).Row ' formule pour recuperer le N° de la dernière ligne du tableau
    Range("A3:T" & b).Select ' selection du tableau allant de la cellule B3 a la derniere cellule de la colonne T
    Selection.Copy
    'ouvrir le fichier "analyse retard 2008"
    Workbooks.Open Filename:="C:\Documents and Settings\GHEMMAZI Hayette\Desktop\analyse retard 2008.xls"
    Windows("analyse retard 2008.xls").Activate
    Range("B1").Select
    If Range("B2").Value <> "" Then Range("B1").End(xlDown).Select 'Si la cellule B2 n'est pas vide,
    'on selectionne la derniere cellule vnon vide de la colonne A. Si A2 est libre, la derniere cellule non vide est A1.
    'Il n'est pas necesaire de se deplacer.
    ActiveCell.Offset(1, 0).Select 'On selectionne la cellule situee une ligne en dessous de la cellule active.
    'Enfait, on se positionne sur la premiere ligne vide de la feuille "analyse retard 2008".
    Lig = ActiveCell.Row
 
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' on copie le tableau
    'selectionner a partir de la premiere ligne  vide de la feuille "analyse retard 2008
    Application.CutCopyMode = False 'instrcution qui permet d'effacer la marque de selection autor de la plage copiee
    Cells(Lig, 1).Value = DateEnCours
    Application.ScreenUpdating = True 'la mise à jour de l'écran est activée
 
End Sub

Ton module de copie fonctionne bien. J'ai seulement ajouté du code pour :
- recopier la date de A1 en A...Lig
- désactiver la mise à jour de l'écran pour éviter les affichages perturbents

Si tu es intéressé je peux te passer un module qui permet d'aller chercher et ouvrir un fichier XLS dans un répertoire que tu choisis

à plus

**facteur** · 15/04/2008, 20h23

Et encore merci Pierre
La macro marche a merveille.
Il ne me reste plus qu'à essayer de continuer à élaborer cette macro retard

.

Je serais tres interessé par ce module qui permet d'aller récuperer un fichier xls.

Pierre pourrais tu aussi m'expliquer ces deux lignes :
On Error Resume Next
On Error GoTo 0

**Le Pierre** · 16/04/2008, 11h11

bonjour

Si tu utilises la commande "ActiveSheet.ShowAllData" (pour visualiser toutes le données de la zone filtrée) et que les données sont déjà visibles il y aura une erreur.
Dans le morceau de code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

en cas d'erreur sur la commande, grâce à "On Error Resume Next" on passe à la ligne suivante et pour éviter cette gestion d'erreur sur une autre erreur éventuellemnt rencontrée plus loin, on utilise "On Error GoTo 0" pour annuler la gestion des erreurs.

Voici le code pour rechercher des fichiers (RechercheFichier) dans un répertoire et leur appliquer un éventuel traitement (dans le module test, il n'y a que l'ouverture et la fermeture sans sauvegarde des fichiers xls présents dans le répertoire) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Sub test()
    Application.ScreenUpdating = False
 
    Fichier_Analyse = ThisWorkbook.Name
    Call RechercheFichier(Chemin, Fichier)
    Windows(Fichier_Analyse).Activate
 
    Fichier_à_Analyser = Dir(Chemin & "\*.xls")
    If Fichier_à_Analyser <> "" Then
        Do
            Application.StatusBar = "Traitement du fichier " & Fichier_à_Analyser
 
            Workbooks.Open Filename:= _
                Chemin & "\" & Fichier_à_Analyser, local:=True
            Windows(Fichier_à_Analyser).Activate
 
            '-----------------
            '---place ici ton code de traitement
            '-----------------
 
 
            '-----------------
            Windows(Fichier_à_Analyser).Activate
            ActiveWindow.Close SaveChanges:=False
 
            Fichier_à_Analyser = Dir
            If Fichier_à_Analyser = "" Then Exit Do
        Loop
    End If
    Application.StatusBar = ""
    Beep
    Application.ScreenUpdating = True
 
End Sub
 
Sub RechercheFichier(Chemin, Fichier)
    If Chemin <> "" Then
        '--- Se place dans le répertoire de l'application ---
        Path = Chemin
        Lect = Left(Path, 1)
        ChDrive Lect
        If InStr(1, Path, "\", 1) <> 0 Then
            ChDir Path
        End If
    End If
 
    fileToOpen = Application _
        .GetOpenFilename("(*.xls),*.xls")
 
    x = 0
    Do
        x = InStr(x + 1, fileToOpen, "\")
        If x = 0 Then Exit Do
        Memox = x
    Loop Until x = 0
    Chemin = Left(fileToOpen, Memox)
    Fichier = Right(fileToOpen, Len(fileToOpen) - Memox)
 
    '--- Se place dans le répertoire de l'application ---
    Path = Chemin
    Lect = Left(Path, 1)
    ChDrive Lect
    If InStr(1, Path, "\", 1) <> 0 Then
        ChDir Path
    End If
End Sub

à plus

creer des sous totaux en VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager