Trier une base de données par une date

Hola à tous,

Je me permets de solliciter votre expertise VBA.

Voilà mon besoin: Je souhaiterais aider les opérateurs d'un entrepôt pour qu'ils aient sur un fichier excel les livraisons de la semaine à venir.

La situation: Imaginons le procédé, chaque Lundi matin un opérateur sort d'un ERP une base de données qui englobent toutes les livraisons de la semaine. Je souhaiterais que cette base de données se range par dates de livraison.

A l'image de l'exemple joint, nous sommes le Lundi 23: le fichier se distribuerait jusqu'au dimanche s'il y avait une livraison de prévue.

Dans l' onglet rouge, il s'agit de ce que l'on extrait de l'ERP. En jaune, les onglets que l'on souhaiterait créer via une macro.

L'idée est donc de copier les colonnes D F G H K L M dans des onglets nommés en fonction de la date de livraison.

Le top serait,en plus, d'avoir une mise en forme automatique en tableau de chaque onglet là on toucherait au saint graal.

J'avais un début de macro trouvée sur un autre topic mais elle ne marche pas pour mon cas...

https://forum.excel-pratique.com/excel/repartir-d-un-onglet-vers-plusieurs-onglets-selon-criteres-t39550.html

Sub Répartition()

Dim DLig As Long

Dim Mondico As Object

Dim aa As String

Dim J As Long

Dim Tablo

Application.ScreenUpdating = False

' Partie distribution des infos

Set Mondico = CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")

DLig = .Range("A" & Rows.Count).End(xlUp).Row

For J = 12 To DLig

Mondico(.Range("C" & J).Value) = .Range("C" & J).Value

Next J

Tablo = Mondico.Items

End With

For J = 0 To Mondico.Count - 1

If FeuilleExiste(CStr(Tablo(J))) = False Then

Sheets("Feuil1").Copy after:=Sheets(Sheets.Count)

aa = Tablo(J)

ActiveSheet.Name = Tablo(J)

Range("2:11").Delete

With Sheets(aa)

.Select

.Rows("1:1").AutoFilter

.Range("A2:D" & DLig).AutoFilter Field:=3, Criteria1:=aa 'Dlig correspond à la dernière ligne de la feuille 1

End With

End If

Next J

Application.ScreenUpdating = True

End Sub

Function FeuilleExiste(nom As String) As Boolean

On Error Resume Next

FeuilleExiste = Sheets(nom).Name <> ""

On Error GoTo 0

End Function

Au plaisir de vous répondre pour de plus amples informations,

Cordialement

Bonjour,

Un test

Bonjour à tous,

Une autre proposition à étudier.

ALT F8, exécuter la procédure.

Cdlt.

Bonjour à vous 2 et merci pour avoir pris le temps de me répondre,

J'ai travaillé sur la proposition d'M12 avant que Jean Eric ne réponde plus précisément à mon problème et un soucis mineur persiste.

Je souhaiterais mettre en forme les nouveaux onglets sous forme de tableaux avec bien sûr comme en-têtes la ligne 1

Est-ce possible? Car avec l'enregistreur de macro cela bloque.

Bonne fin de journée

Re,

Dans ma proposition, les données sont mises sous forme de tableaux. Voir le gestionnaire de noms.

Cdlt.

Au temps pour moi, j'avais un peu la tête dans le guidon

merci !

Re,

De rien...

Bonne fin de journée.

Bonjour tout le monde,

Voila la macro de Jean Eric marchait très bien pour hier,

Mais elle ne marche plus maintenant que nous avons changé de jour.

En effet, au lieu de chercher des dates sur la semaine à venir, elle les cherche pour le 29/12/1899 jusqu'au 04/01/1900

C'est sûr qu'à ce moment là aucune livraison n'était prévu

Avez-vous une idée pour "réparer" la macro?

Bonne journée

Bonjour,

Teste en remplaçant le code par celui-ci

Public Sub Create_Worksheets()
Dim wb As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim start_Date As Date, end_Date As Date
Dim rng As Range, rng2 As Range
Dim i As Long

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

    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("Datasetting")
    For Each ws In wb.Worksheets
        If ws.Name <> wsData.Name Then ws.Delete
    Next ws

    Application.DisplayAlerts = False

    With wsData
        If .Cells(1).ListObject Is Nothing Then
            Set lo = .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes)
            With lo
                .Name = "tbl_Data"
                .TableStyle = ""
            End With
        Else
            Set lo = .ListObjects(1)
        End If
    End With

    start_Date = Date - (Date - 2) Mod 7
    end_Date = start_Date + 6

    If lo.ShowAutoFilter Then lo.AutoFilter.ShowAllData

    For i = start_Date To end_Date
        Set rng = Nothing
        lo.Range.AutoFilter field:=11, _
                            Criteria1:=Format(i, "dd/mm/yyyy")
        With lo.AutoFilter.Range
            On Error Resume Next
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        If rng Is Nothing Then
            MsgBox "Il n'y a pas de livraison prévue le " & Format(i, "dddd dd mmmm yyyy") & "."
        Else
            Set ws = wb.Worksheets.Add(after:=wb.Worksheets(Worksheets.Count))
            ws.Name = Format(i, "ddmmyyyy")
            Set rng2 = lo.AutoFilter.Range
            rng2.Offset(, 3).Resize(, 10).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Cells(1)
            Set lo2 = ws.ListObjects.Add(xlSrcRange, ws.Cells(1).CurrentRegion, , xlYes)
            With lo2
                .Name = "tbl_" & ws.Name
                .TableStyle = ""
                .HeaderRowRange.EntireColumn.AutoFit
            End With
        End If
    Next i

    lo.Range.AutoFilter field:=11

    Set rng2 = Nothing: Set rng = Nothing
    Set lo2 = Nothing: Set lo = Nothing
    Set ws = Nothing: Set wsData = Nothing
    Set wb = Nothing

End Sub

Bonjour,

Bonjour M12,

Modifie ainsi :

start_date=Date-Weekday(Date,3)

A te relire.

Cdlt.

Bonjour Jean Eric

J'ai remplacé par ceci (en modulo)

 start_Date = Date - (Date - 2) Mod 7

Bonjour,

Merci à vous 2 cela marche, je valide la solution et je réouvrirai si je vois un autre problème.

Bonne journée