Microsoft 365 Consolider une BD vers plusieurs onglets avec 2 conditions

ivan27

XLDnaute Occasionnel
Bonjour à tous,

J'ai besoin d'effectuer une consolidation d'une BD vers plusieurs onglets, selon 2 critères.

1 - Je dois pouvoir choisir la période de consolidation, par exemple du 01/08/2020 au 31/08/2020 (la date se trouve en colonne B qui est triée en ordre décroissant)
2 - Sur la période choisie, créer un onglet par code de la colonne A (voir exemple 7520 et 7543)

Enfin, sur chaque feuille créée, ajouter des totaux sur 9 colonnes

la BD compte environ 1000 lignes par mois et 40 à 50 codes (colonne A) différents.

J'ai bien trouvé quelques exemples mais sans le choix de la période, ni les totaux en pied de colonnes.

Merci d'avance pour votre aide

Ivan
 

Pièces jointes

  • TestConsolidation.xlsx
    196.7 KB · Affichages: 14
Solution
Dans ce fichier (2) on utilise le filtre avancé, c'est nettement plus rapide :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dat1, dat2, exclu, colonne, i&, BD As Worksheet, critere As Range, d As Object, tablo, dat, x$, col
dat1 = [D4]: dat2 = [D5]
If Not IsDate(dat1) Or Not IsDate(dat2) Then Exit Sub
exclu = Array("Accueil", "BD") 'feuilles à exclure, à adapter
colonne = Array(8, 9, 10, 11, 12, 13, 14, 16, 17, 19) 'numéros des colonnes, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
    If IsError(Application.Match(Worksheets(i).Name, exclu, 0)) Then Worksheets(i).Delete
Next
Set BD = Sheets("BD")
Set critere = BD.UsedRange(2...

Nairolf

XLDnaute Accro
Salut,

On pourrait faire des choses en vba, mais je n'ai pas saisi l'intérêt d'avoir plein d'onglets pour remettre des valeurs déjà existantes dans l'onglet "BD" que nous pouvons avoir en faisant un filtre sur les champ désirés directement dans l'onglet "BD".

De plus avec un Tableau Croisé Dynamique (TCD), on peut faire un bilan des données de l'onglet "BD".
Et si tu le paramètres avec une chronologie sur la colonne de date désirée et un segment sur le champ à filtrer, tu obtiendras les totaux correspondants aux critères choisis.
Je suis parti sur ces principes pour la réalisation des fichiers joints.

N'ayant pas tout à fait compris ta remarque sur le second message, je t'ai mis 2 fichiers l'un avec un segment sur la colonne A et l'autre sur la colonne B.
 

Pièces jointes

  • TestConsolidation_Nairolf.xlsx
    250 KB · Affichages: 2
  • TestConsolidation_Nairolf2.xlsx
    249.7 KB · Affichages: 2

ivan27

XLDnaute Occasionnel
Re bonjour le forum, Nairolf
Merci pour ta proposition
Les données anonymisées constituent une liste de transports.
La colonne A correspond à un conducteur et la colonne X à une entreprise de transports.
Ma demande consiste à regrouper sur un mois donné toutes les lignes d'une même entreprise de transport (colonne X)
Par la suite, je communiquerai chaque feuille au transporteur concerné.
Bien cordialement
 

job75

XLDnaute Barbatruc
Bonjour ivan27, Nairolf,

Voyez le fichier joint et cette macro dans le code de la feuille "Accueil" :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dat1, dat2, exclu, i&, BD As Worksheet, d As Object, tablo, dat, x$, col, w As Worksheet
dat1 = [D4]: dat2 = [D5]
If Not IsDate(dat1) Or Not IsDate(dat2) Then Exit Sub
exclu = Array("Accueil", "BD") 'feuilles à exclure, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
    If IsError(Application.Match(Worksheets(i).Name, exclu, 0)) Then Worksheets(i).Delete
Next
Set BD = Sheets("BD")
tablo = BD.[A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo)
    dat = tablo(i, 2)
    If IsDate(dat) Then
        If CDate(dat) >= dat1 And CDate(dat) <= dat2 Then
            x = CStr(tablo(i, 24))
            If Not d.exists(x) Then
                Set d(x) = Sheets.Add(After:=Sheets(Sheets.Count))
                d(x).Name = x
                BD.Rows(1).Copy d(x).Cells(1) 'copier-coller des en-têtes
            End If
            BD.Rows(i).Copy d(x).Cells(Rows.Count, 1).End(xlUp)(2) 'copier-coller
        End If
    End If
Next
'---totaux---
col = Array(8, 9, 10, 11, 12, 13, 14, 16, 17, 19) 'numéros des colonnes, à adapter
For Each w In Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) Then
        With w.Cells(Rows.Count, 1).End(xlUp)(2)
            For i = 0 To UBound(col)
                .Cells(0, col(i)).AutoFill .Cells(0, col(i)).Resize(2), xlFillFormats
                .Cells(1, col(i)) = "=SUM(R1C:R[-1]C)"
            Next
            .EntireRow.Font.Bold = True 'gras
            .EntireRow.Font.ColorIndex = 3 'police rouge
        End With
    End If
Next
Application.Goto Target
End Sub
Elle s'exécute quand les dates en D4 et D5 sont renseignées.

A+
 

Pièces jointes

  • TestConsolidation(1).xlsm
    203.9 KB · Affichages: 3
Dernière édition:

ivan27

XLDnaute Occasionnel
job75
Petit problème sur mon fichier d'exploitation.
Les vrais noms d'entreprises ne commencent pas par ''ENT''
Est-il possible de corriger le code pour supprimer toutes les feuilles ''à partir de la Feuil8''
Bien cordialement,
Ivan
 

Nairolf

XLDnaute Accro
Salut Job75, Re Ivan,

Je vois qu'une réponse à déjà été fournie, comme j'ai travaillé dessus je mets aussi mon ébauche (perfectible) :
VB:
Sub Extraction()
Dim Entreprise As String
Dim NbLignesBD As Integer
Dim i As Integer
Dim DateDébut
Dim DateFin

Sheets("BD").Select

NbLignesBD = Application.WorksheetFunction.CountA(Sheets("BD").Columns("X:X"))

DateDébut = "01/01/1900"
DateFin = Format(Now, "dd\/MM\/yyyy")
DateDébut = InputBox("Date de début au format jj/mm/aaaa :")
DateFin = InputBox("Date de Fin au format jj/mm/aaaa :")
If DateDébut = "" Or DateFin = "" Then Exit Sub

For i = 2 To NbLignesBD
Entreprise = Sheets("BD").Range("X" & i)

If Application.WorksheetFunction.CountIf(Sheets("BD").Range("X1:X" & i - 1), Entreprise) = 0 Then
    ActiveSheet.Range("$A$1:$X$1456").AutoFilter Field:=24, Criteria1:=Entreprise
    ActiveSheet.Range("$A$1:$X$1456").AutoFilter Field:=2, Criteria1:= _
        ">=08/08/2020", Operator:=xlAnd, Criteria2:="<=20/08/2020"
    Range("A1:X1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.End(xlDown).Select
    ActiveSheet.Select
    ActiveSheet.Name = Entreprise & "_" & Replace(DateDébut, "/", "-") & " à " & Replace(DateFin, "/", "-")
    
    Range("A1").Select
    Selection.End(xlDown).Select
    If Application.WorksheetFunction.CountA(ActiveSheet.Columns("A:A")) = 1 Then
        LigneTOTAL = 2
        Else
            LigneTOTAL = ActiveCell.Row + 1
    End If
    Range("A" & LigneTOTAL).FormulaR1C1 = "TOTAL"
    Range("H" & LigneTOTAL).Select
    Application.CutCopyMode = False
    ActiveCell.Formula2 = "=SUM(H2:H" & LigneTOTAL - 1 & ")"
    Selection.Copy
    Range("I" & LigneTOTAL & ":N" & LigneTOTAL & ",S" & LigneTOTAL & ",U" & LigneTOTAL).Select
    ActiveSheet.Paste
    Rows(LigneTOTAL - 1 & ":" & LigneTOTAL - 1).Select
    Selection.Copy
    Rows(LigneTOTAL & ":" & LigneTOTAL).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Font.Bold = True
    Range("A1").Select
    
    Application.CutCopyMode = False
    'Sheets(Entreprise).Move
    'Sheets(Entreprise).Select
    'ActiveWorkbook.SaveAs Filename:= _
    '    "C:\ivan27\" & Entreprise & ".xlsx", FileFormat:= _
    '    xlOpenXMLWorkbook, CreateBackup:=False
    'ActiveWindow.Close
    Sheets("BD").Select
End If
Next i

Range("A1").Select
ActiveSheet.ShowAllData

End Sub
A noter que ce qui est précédé d'un apostrophe est pour générer des fichiers individuels par Entreprise.
 

job75

XLDnaute Barbatruc
Dans ce fichier (2) on utilise le filtre avancé, c'est nettement plus rapide :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dat1, dat2, exclu, colonne, i&, BD As Worksheet, critere As Range, d As Object, tablo, dat, x$, col
dat1 = [D4]: dat2 = [D5]
If Not IsDate(dat1) Or Not IsDate(dat2) Then Exit Sub
exclu = Array("Accueil", "BD") 'feuilles à exclure, à adapter
colonne = Array(8, 9, 10, 11, 12, 13, 14, 16, 17, 19) 'numéros des colonnes, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
    If IsError(Application.Match(Worksheets(i).Name, exclu, 0)) Then Worksheets(i).Delete
Next
Set BD = Sheets("BD")
Set critere = BD.UsedRange(2, BD.UsedRange.Columns.Count + 2)
tablo = BD.[A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo)
    dat = tablo(i, 2)
    If IsDate(dat) Then
        If CDate(dat) >= dat1 And CDate(dat) <= dat2 Then
            x = CStr(tablo(i, 24))
            If Not d.exists(x) Then
                Set d(x) = Sheets.Add(After:=Sheets(Sheets.Count))
                d(x).Name = x
                critere = "=AND(--B2>=" & CLng(dat1) & ",--B2<=" & CLng(dat2) & ",X2=""" & x & """)"
                With BD.Cells(1).CurrentRegion
                    .AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
                    .SpecialCells(xlCellTypeVisible).Copy d(x).Cells(1) 'copier-coller
                End With
                With d(x).Cells(Rows.Count, 1).End(xlUp)(2)
                    For Each col In colonne
                        .Cells(0, col).AutoFill .Cells(0, col).Resize(2), xlFillFormats
                        .Cells(1, col) = "=SUM(R1C:R[-1]C)"
                    Next col
                    .EntireRow.Font.Bold = True 'gras
                    .EntireRow.Font.ColorIndex = 3 'police rouge
                End With
            End If
        End If
    End If
Next i
critere = ""
Application.Goto Target
End Sub
Testé sur la période 01/08/2020-31/08/2020 :

- fichier (1) => 1,5 seconde

- fichier (2) => 0,6 seconde.
 

Pièces jointes

  • TestConsolidation(2).xlsm
    204.7 KB · Affichages: 4

ivan27

XLDnaute Occasionnel
Bonsoir le forum, Nairolf, job75,
Merci pour vos corrections et propositions complémentaires.
job75, effectivement le fichier 2, tester sur une liste conséquente, est bien plus rapide que le premier !
Bon week-end à tous
Ivan
 

Discussions similaires