Modification de code VBA

Le 04/02/2016 à 10:01

Bonjour à tous les membres de la communauté !

Je souhaiterai modifier mon code VBA afin que:

Qu'une fonction "TOTAL" au bas de la colonne "Commission" dans chaque feuille s'ajoute.

Que les éditions (colonne H) n'ayant pas de montant renseigné dans Facture total (colonne I) n'aient pas de feuille consacrée (ex: Edition H)

Que la feuille "Données" ne change pas après exécution de la macro.

Que je puisse rajouter des lignes et des colonnes à ma guise sans perturber l'exécution de la macro.

Option Explicit

Public Sub cmdCreateWorksheets_Click()
'Declaration des variables
Dim ws As Worksheet, ws2 As Worksheet, WSnew As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim Cell As Range
Dim FieldNum As Long, lRow As Long
    'Optimisation code
    With Application
        .DisplayAlerts = False
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
    'Suppression des feuilles sauf la feuille active (feuille Donnees)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then ws.Delete
    Next ws
    'Initialisation des variables
    Set ws = ActiveSheet    'Feuille Donnees
    Set lo = ws.ListObjects(1)  'Tableau feuille Donnees (Excel 2007+)
    FieldNum = 8    'Numero colonne pour le filtre avancé (colonne Edition)
    'RAZ filtes tableau feuille Donnees
    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then lo.AutoFilter.ShowAllData
    Else
        lo.ShowAutoFilter = True
    End If
    'Creation feuille temporaire (qui sera supprimee en fin de procédure)
    'La feuille va recevoir la liste des valeurs uniques de la colonne 8 (FieldNum)
    Set ws2 = ActiveWorkbook.Worksheets.Add
    With ws2
        'On cree la liste unique des valeurs de la colonne 8 (Colonne Edition / Utilisation filtre avancé)
        lo.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Cells(1), _
                Unique:=True
        'Nombre de valeurs uniques du filtre avance
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        'Pour chaque element de la liste unique (Edition)
        For Each Cell In .Range("A2:A" & lRow)
            'On effectue le filtrage suivant l'item
            lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
            'On cree la nouvelle feuille qui va recevoir les donnees filtrees
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            'On nomme la nouvelle feuille avec la valeur de l'element
            WSnew.Name = Cell.Value
            'On copie la plage filtrée (tableau feuille Donnees)
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSnew
                'On colle la copie
                With .Range("A1")
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                Application.CutCopyMode = False
                'On cree un nouveau tableau (Excel 2007+)
                Set lo2 = .ListObjects.Add(xlSrcRange, WSnew.Cells(8).CurrentRegion, , xlYes)
                With lo2
                    'On determine le style du tableau
                    .TableStyle = "TableStyleLight1"
                End With
                'On active la nouvelle feuille la mise en forme (minimale)
                .Activate
                .Cells(1).Select
                ActiveWindow.DisplayGridlines = False
            End With
            'On efface le filtre de la colonne 8 (Edition)
            lo.Range.AutoFilter Field:=FieldNum
        Next Cell
    End With
    'On supprime la feuille temporaire
    ws2.Delete
    'On active la feuille Donnees
    ws.Activate

    MsgBox "Terminé"

    With Application
        .DisplayAlerts = True
        '.EnableEvents = True
    End With
    'On réinitialise les variables (on vide la mémoire)
    Set lo = Nothing
    Set WSnew = Nothing: Set ws2 = Nothing: Set ws = Nothing

End Sub

Merci à ceux m'apportant des éléments de réponse !

18tableau-factures.xlsm (38.26 Ko)
Le 07/02/2016 à 17:13

Bonsoir,

rajout de la ligne totaux avec pour la colonne commission le total de la somme :

                With lo2
                    'On determine le style du tableau
                    .TableStyle = "TableStyleLight1"
                   .ShowTotals = True
                   .ListColumns("Comission "). _
                        TotalsCalculation = xlTotalsCalculationSum
                End With

@ bientôt peut-être pour le reste

LouReeD

Le 07/02/2016 à 18:56

Re bonsoir,

le code complet :

Public Sub cmdCreateWorksheets_Click()
'Declaration des variables
Dim ws As Worksheet, ws2 As Worksheet, WSnew As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim Cell As Range
Dim FieldNum As Long, lRow As Long
Dim letotal
'*****************
Dim NB_Lignes_Données As Long
'*****************
    'Optimisation code
    With Application
        .DisplayAlerts = False
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
    'Suppression des feuilles sauf la feuille active (feuille Donnees)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then ws.Delete
    Next ws
    'Initialisation des variables
    Set ws = ActiveSheet    'Feuille Donnees
    Set lo = ws.ListObjects(1)  'Tableau feuille Donnees (Excel 2007+)
    FieldNum = 8    'Numero colonne pour le filtre avancé (colonne Edition)
    'RAZ filtes tableau feuille Donnees
    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then lo.AutoFilter.ShowAllData
    Else
        lo.ShowAutoFilter = True
    End If
'*****************
    'Nombre de lignes de la feuille Données
    NB_Lignes_Données = ws.Cells(Rows.Count, FieldNum).End(xlUp).Row
'*****************
    'Creation feuille temporaire (qui sera supprimee en fin de procédure)
    'La feuille va recevoir la liste des valeurs uniques de la colonne 8 (FieldNum)
    Set ws2 = ActiveWorkbook.Worksheets.Add
    With ws2
        'On cree la liste unique des valeurs de la colonne 8 (Colonne Edition / Utilisation filtre avancé)
        lo.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Cells(1), _
                Unique:=True
        'Nombre de valeurs uniques du filtre avance
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
'*****************
        ' on affiche la ligne des totaux avec en colonne édition la formule somme
                    lo.ShowTotals = True
                    lo.ListColumns("Édition"). _
                        TotalsCalculation = xlTotalsCalculationSum
'*****************
        'Pour chaque element de la liste unique (Edition)
        For Each Cell In .Range("A2:A" & lRow)
            'On effectue le filtrage suivant l'item
            lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
'*****************
            If ws.Range("I" & NB_Lignes_Données + 1) > 0 Then
'*****************
                'On cree la nouvelle feuille qui va recevoir les donnees filtrees
                Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
                'On nomme la nouvelle feuille avec la valeur de l'element
                WSnew.Name = Cell.Value
                'On copie la plage filtrée (tableau feuille Donnees)
                lo.Range.SpecialCells(xlCellTypeVisible).Copy
                With WSnew
                    'On colle la copie
                    With .Range("A1")
                        .PasteSpecial xlPasteColumnWidths
                        .PasteSpecial xlPasteValuesAndNumberFormats
                    End With
                    Application.CutCopyMode = False
                    'On cree un nouveau tableau (Excel 2007+)
                    Set lo2 = .ListObjects.Add(xlSrcRange, WSnew.Cells(8).CurrentRegion, , xlYes)
                    With lo2
                        'On determine le style du tableau
                        .TableStyle = "TableStyleLight1"
                        .ShowTotals = True
                        .ListColumns("Comission "). _
                            TotalsCalculation = xlTotalsCalculationSum
                    End With
                    'On active la nouvelle feuille la mise en forme (minimale)
                    .Activate
                    .Cells(1).Select
                    ActiveWindow.DisplayGridlines = False
                End With
                'On efface le filtre de la colonne 8 (Edition)
                lo.Range.AutoFilter Field:=FieldNum
'*********************
            End If
'*********************
        Next Cell
    End With
'*********************
    ' on enlève la ligne des totaux
    lo.ShowTotals = False
'*********************
    'On supprime la feuille temporaire
    ws2.Delete
    'On active la feuille Donnees
    ws.Activate

    MsgBox "Terminé"

    With Application
        .DisplayAlerts = True
        '.EnableEvents = True
    End With
    'On réinitialise les variables (on vide la mémoire)
    Set lo = Nothing
    Set WSnew = Nothing: Set ws2 = Nothing: Set ws = Nothing

End Sub

Principe, on calcul le nombre de ligne de la feuille donnée ce qui nous donne la référence de la cellule total de la colonne facture, une fois un filtre "édition" fait on vérifie que cette valeur est supérieur à 0 si c'est le cas on crée une nouvelle feuille sinon on fait le filtre suivant.

Le code reprend la modification de l'ajout de la ligne total des feuilles ainsi crées.

Ceci n'est qu'une des solutions, certaines plus pro ne devraient pas tarder à arrivées

@ bientôt

LouReeD

Le 07/02/2016 à 20:06

Bonjour,

Bonjour LouReeD,

19xlp-listobject-advancedautofilter-v2.xlsm (23.85 Ko)
Option Explicit

Public Sub cmdCreateWorksheets_Click()
Dim ws As Worksheet, ws2 As Worksheet, WSnew As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim Cell As Range
Dim lRow As Long

    With Application
        .DisplayAlerts = False
        '.EnableEvents = False
        .ScreenUpdating = False
    End With

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then ws.Delete
    Next ws

    Set ws = ActiveSheet
    Set lo = ws.ListObjects(1)

    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then lo.AutoFilter.ShowAllData
    Else
        lo.ShowAutoFilter = True
    End If

    Set ws2 = ActiveWorkbook.Worksheets.Add
    With ws2
        lo.ListColumns(9).Range.AutoFilter field:=9, Criteria1:="<>"
        lo.ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
        .Cells(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .Cells(1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For Each Cell In .Range("A1:A" & lRow)
            lo.Range.AutoFilter field:=8, Criteria1:="=" & Cell.Value
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            WSnew.Name = Cell.Value
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSnew
                With .Cells(1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                Application.CutCopyMode = False
                Set lo2 = .ListObjects.Add(xlSrcRange, WSnew.Cells(8).CurrentRegion, , xlYes)
                With lo2
                    .TableStyle = "TableStyleLight1"
                    .ShowTotals = True
                    .ListColumns(10).TotalsCalculation = xlTotalsCalculationSum
                End With
                .Activate
                .Cells(1).Select
                ActiveWindow.DisplayGridlines = False
            End With
        Next Cell
    End With

    lo.AutoFilter.ShowAllData
    ws2.Delete
    ws.Activate

    MsgBox "Terminé"

    With Application
        .DisplayAlerts = True
        '.EnableEvents = True
    End With

    Set lo = Nothing
    Set WSnew = Nothing: Set ws2 = Nothing: Set ws = Nothing

End Sub
Le 07/02/2016 à 20:41

Bonsoir,

c'est ce que je disais à peine 1 quart d'heure et hop le miracle !

Evidemment Jean-Eric le fait de filtrer sur les différents de vide permet du coup de supprimer les éditions sans valeurs !!!

Je n'arrive pas à avoir cette vision des problèmes, plutôt des solutions

Bravo à vous une fois de plus !

@ bientôt

LouReeD

Le 09/02/2016 à 10:37

Meeeeeeeeeeeeeeerci LouReeD ! Et encore une fois, merci Jean-Eric !

Cependant, je rencontre un problème (de taille) et que je n'explique pas:

Au début, ma macro fonctionne à merveille et puis, lorsque je remplis davantage d'informations dans mon tableau, elle cesse de fonctionner...

14copie-de-xlp-listobject-advancedautofilter-v2.xlsm (102.34 Ko)
Le 09/02/2016 à 11:08

Bonjour,

Fais une petite recherche avec notre ami Google ou autre sur le nombre de caractères autorisé pour le nom d'une feuille de calcul.

A te relire.

Cdlt.

Le 10/02/2016 à 09:26

Bonjour Jean-Eric,

Le moteur de recherche ne spécifie rien à ce sujet.

De ce fait, j'ai réalisé des test et, 31 caractères (comprenant les espaces) maximum sont autorisés.

Je vais tâcher de trouver une solution à ce propos.

Concernant le code que vous m'avez largement aidé à mettre en place, j'aimerai pouvoir le modifier, à nouveau:

Afin que seules les "lignes" pour lesquelles il y a une absence de renseignements dans la colonne "Commission" soient reportées dans l'onglet relatif à l'Edition et non toutes les lignes relatives à cette édition. (voir fichier joint pour davantage de compréhension)

13copie-de-xlp-listobject-advancedautofilter-v2.xlsm (24.37 Ko)
Le 13/02/2016 à 21:54

Bonjour,

Si je peux me permettre, une solution (?) :

        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For Each Cell In .Range("A1:A" & lRow)
            lo.Range.AutoFilter field:=8, Criteria1:="=" & Cell.Value
            lo.Range.AutoFilter field:=10, Criteria1:=""
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            WSnew.Name = Cell.Value
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSnew

Evidemment vous l'avez vu, c'est une partie du code

Il faut juste rajouter la partie surlignée...

@ bientôt

LouReeD

Le 14/02/2016 à 08:20

Bonjour LouReeD,

Pour info.

https://forum.excel-pratique.com/excel/condition-supplementaire-macro-vba-t73907.html

Et le code final(isé).

Cdlt.

Option Explicit

Public Sub cmdCreateWorksheets_Click()
'Declaration des variables
Dim ws As Worksheet, ws2 As Worksheet, WSnew As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim Cell As Range
Dim lRow As Long
    'Optimisation du code
    With Application
        .DisplayAlerts = False
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
    'Suppression des feuilles sauf la feuille active (feuille Donnees)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then ws.Delete
    Next ws
    'Initialisation des varialbes
    Set ws = ActiveSheet    'Feuilles Donnees
    Set lo = ws.ListObjects(1)    'Tableau feuille Données (Excel 2007+)

    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then lo.AutoFilter.ShowAllData
    Else
        lo.ShowAutoFilter = True
    End If
    'Creation feuille temporaire (qui sera supprimée en fin de procédure)
    'La feuille va recevoir la liste des valeurs uniques de la colonne 8 (Field Num)
    Set ws2 = ActiveWorkbook.Worksheets.Add
    With ws2
        lo.ListColumns(6).Range.AutoFilter field:=6, Criteria1:="<>"
        lo.ListColumns(9).Range.AutoFilter field:=9, Criteria1:="<>"
        lo.ListColumns(9).Range.AutoFilter field:=10, Criteria1:="="
        lo.ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
        .Cells(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .Cells(1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
        'Nombre de valeurs uniques du filtre avancé
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        'Pour chaque élément de la liste unique (Edition)
        For Each Cell In .Range("A1:A" & lRow)
            'On effectue le filtrage suivant l'item
            lo.Range.AutoFilter field:=8, Criteria1:="=" & Cell.Value
            'On crée la nouvelle feuille qui va recevoir les données filtrées
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            'On nomme la nouvelle feuille avec la valeur de l'élément
            WSnew.Name = Cell.Value
            'On copie la plage filtrée (tableau feuille Données)
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSnew
                With .Cells(1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                Application.CutCopyMode = False
                .Columns("A:E").Delete shift:=xlToLeft
                'On crée un nouveau tableau (Excel 2007+)
                Set lo2 = .ListObjects.Add(xlSrcRange, WSnew.Cells(1).CurrentRegion, , xlYes)
                With lo2
                    'On détermine le style du tableau
                    .TableStyle = "TableStyleLight1"
                    .ShowTotals = True
                    .ListColumns(5).TotalsCalculation = xlTotalsCalculationSum
                End With
                'On active la nouvelle feuille la mise en forme (minimale)
                .Activate
                .Cells(1).Select
                ActiveWindow.DisplayGridlines = False
            End With
        Next Cell
    End With

    lo.AutoFilter.ShowAllData
    'On supprime la feuille temporaire
    ws2.Delete
    'On active la feuille Données
    ws.Activate

    MsgBox "Terminé"

    With Application
        .DisplayAlerts = True
        '.EnableEvents = True
    End With
    'On réinitialise les variables (on vide la mémoire)
    Set lo = Nothing
    Set WSnew = Nothing: Set ws2 = Nothing: Set ws = Nothing

End Sub
Le 14/02/2016 à 13:40

Bonjour,

je trouvais bizarre le fait qu'il n'y est pas de réponse de votre part Jean-Eric !

J'avais bien raison... mais pourquoi poser la même question sur plusieurs post ?!

@ bientôt

LouReeD

Le 15/02/2016 à 13:34

Bonjour LouReeD,

Après avoir posé la question sur ce post, il m'a semblé qu'il serait judicieux d'ouvrir un post qui serait consacré à un sujet en particulier, car le sujet soulevé était différent du sujet initial. Peut être ne l'était-ce point, judicieux. En ce sens, je vous prie d'accepter mes excuses.

Le 15/02/2016 à 18:07

Bonsoir,

nul besoin d'excuses !

C'était juste une question pour justifier ma réponse "dans le vide" !

Loin de moi l'idée de vouloir faire la morale

@ très bientôt sur le forum sur un autre post

LouReeD

Rechercher des sujets similaires à "modification code vba"