Microsoft 365 Consolider une BD vers plusieurs onglets avec 2 conditions

[ivan27]

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

 

[ivan27]

Re bonjour à tous,

''Petite'' modification dans ma demande, désolé...
La consolidation vers les onglets doit se faire sur la colonne X et non pas sur la colonne A.
Bien cordialement,

 

[Nairolf]

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.

 

[ivan27]

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]

Bonjour ivan27, Nairolf,

Voyez le fichier joint et cette macro dans le code de la feuille "Accueil" :

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+

 

[ivan27]

Rebonjour, le forum, Nairolf, job75
Un très grand merci pour cette proposition juste Géniale !
Bon week-end
Ivan

 

[ivan27]

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]

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) :

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]

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''

Je viens de corriger mon post #5, il vous faudra adapter l'Array exclu dans la macro.

 

[job75]

Dans ce fichier (2) on utilise le filtre avancé, c'est nettement plus rapide :

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.

 

[ivan27]

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