Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

[lebast]

Bonjour à tous,

je reviens vers vous pour faire appel à vos talents.

j'ai un problème qui me parait simple mais pourtant je n'arrive pas à le résoudre !!

Tout commence par l'extraction d'une base de données (onglet requête) su des expéditions de marchandise.
L'objectif est de remplir le calendrier présent dans la feuille Juin comme celle de la feuille Juin - exemple.

Pour cela j'ai effectué des centaines de recherches sur le forum mais je ne trouve une réponse à mon besoin.

pourriez vous me guider/expliquer ?

n'hésiter pas à revenir vers moi si je ne vous ai pas donné assez de détail.

Merci d'avance

Bastien

 

[Bebere]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

bonjour Lebast
code module 1 et 2

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour lebast,

Voyez le fichier joint et cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim nlig&, ncol%, r As Range, jour As Range, i&, j%
nlig = 18 'nombre de lignes d'un jour
ncol = 3 'nombre de colonnes d'un jour
Application.ScreenUpdating = False
'---RAZ des jours---
For Each r In Sh.UsedRange
  If IsDate(r) Then r(2).Resize(nlig, ncol) = ""
Next
'---remplissage des jours---
For Each r In Feuil1.[A1].CurrentRegion.Columns(1).Cells
  If r.Row > 1 And r <> "" Then
    Set jour = Sh.Cells.Find(r, , xlFormulas, xlWhole)
    If Not jour Is Nothing Then
      For i = 2 To nlig + 1
        If jour(i) = "" Then
          For j = 1 To ncol
            jour(i, j) = r(, j + 1)
          Next j
          Exit For
        End If
      Next i
      If i = nlig + 2 Then MsgBox "Pas assez de place le " & jour
    End If
  End If
Next
End Sub

Edit : salut Bebere, je ne t'avais pas vu.

Bonne soirée.

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Re,

Avec ceci la RAZ est plus rapide :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim nlig&, ncol%, r As Range, jour As Range, i&, j%
nlig = 18 'nombre de lignes d'un jour
ncol = 3 'nombre de colonnes d'un jour
Application.ScreenUpdating = False
'---RAZ des jours---
For Each r In Sh.UsedRange.Rows
  If r.Cells(1) Like "Semaine*" Then r.Cells(2, 2).Resize(nlig, 5 * ncol) = ""
Next
'---remplissage des jours---
For Each r In Feuil1.[A1].CurrentRegion.Columns(1).Cells
  If r.Row > 1 And r <> "" Then
    Set jour = Sh.Cells.Find(r, , xlFormulas, xlWhole)
    If Not jour Is Nothing Then
      For i = 2 To nlig + 1
        If jour(i) = "" Then
          For j = 1 To ncol
            jour(i, j) = r(, j + 1)
          Next j
          Exit For
        End If
      Next i
      If i = nlig + 2 Then MsgBox "Pas assez de place le " & jour
    End If
  End If
Next
End Sub

Fichier (2).

Bonne fin de soirée.

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Re,

Si dans la feuille "Juin" et les autres feuilles les dates sont déterminées par des formules il faut autre chose :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim nlig&, ncol%, r As Range, jour As Range, i&, j%
nlig = 18 'nombre de lignes d'un jour
ncol = 3 'nombre de colonnes d'un jour
Application.ScreenUpdating = False
'---RAZ et formatage des jours---
For Each r In Sh.UsedRange.Rows
  If r.Cells(1) Like "Semaine*" Then
    r.Cells(2, 2).Resize(nlig, 5 * ncol) = ""
    r.NumberFormat = "0"
  End If
Next
'---remplissage des jours---
For Each r In Feuil1.[A1].CurrentRegion.Columns(1).Cells
  If r.Row > 1 And r <> "" Then
    Set jour = Sh.Cells.Find(r.Value2, , xlValues, xlWhole)
    If Not jour Is Nothing Then
      For i = 2 To nlig + 1
        If jour(i) = "" Then
          For j = 1 To ncol
            jour(i, j) = r(, j + 1)
          Next j
          Exit For
        End If
      Next i
      If i = nlig + 2 Then MsgBox "Pas assez de place le " & jour
    End If
  End If
Next
'---reformatage des jours---
For Each r In Sh.UsedRange.Rows
  If r.Cells(1) Like "Semaine*" Then r.NumberFormat = "dddd d mmmm yyyy"
Next
End Sub

Fichier (3).

Bonne nuit.

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour lebast, Bebere, le forum,

S'il y a beaucoup de dates dans la base les solutions précédentes risquent de prendre beaucoup de temps.

En faisant un tri préalable sur les dates ceci devrait être plus rapide :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim nlig&, ncol%, r As Range, col%, dat&, n As Variant, i&, j%
nlig = 18 'nombre de lignes d'un jour
ncol = 3 'nombre de colonnes d'un jour
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
  On Error Resume Next: .ShowAllData: On Error GoTo 0
  .[Z1] = 1
  .UsedRange.Columns(26).DataSeries 'numérotation des lignes
  .UsedRange.Sort .[A1], Header:=xlYes 'tri sur les dates
  For Each r In Sh.UsedRange.Rows
    If r.Cells(1) Like "Semaine*" Then
      r.Cells(2, 2).Resize(nlig, 5 * ncol) = "" 'RAZ
      For col = 2 To 5 * ncol + 1 Step ncol
        dat = r.Cells(1, col)
        n = Application.Match(dat, .[A:A], 0)
        If IsNumeric(n) Then
          i = 2
          Do
            If i = nlig + 2 Then MsgBox "Pas assez de place le " & r.Cells(1, col): Exit Do
            For j = 1 To ncol
              r.Cells(i, col + j - 1) = .Cells(n, j + 1)
            Next j
            i = i + 1: n = n + 1
          Loop While .Cells(n, 1) = dat
        End If
      Next col
    End If
  Next r
  .UsedRange.Sort .[Z1], xlAscending 'ordre initial
  .[Z:Z] = ""
  With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

Edit : en fin de macro l'ordre initial des dates est restitué.

Fichier joint.

A+

 

[lebast]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour à tous,

veuillez excuser mon délais de réponse mais je rentre seulement d'un long déplacement.

Merci pour tout vos retours qui fonctionnement.

La dernière Macro transmise rectifie un bug que je rencontrais avant : les données ne s'actualisaient plus des fois sans que je sache pourquoi.

Je me demandais s'il était possible de faire une petite modification.
Actuellement j'ai définis un nombre de ligne, cependant il y a des jours ou toutes les lignes sont utilisées et d'autres non.

n'est-il pas possible d'adapter le nombre de ligne par semaine en fonction du jours contenant le plus de livraison ?

Encore un énorme merci pour votre aide !

Salutations,

Bastien

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonsoir lebast,

Je n'avais pas vu passer votre message.

n'est-il pas possible d'adapter le nombre de ligne par semaine en fonction du jours contenant le plus de livraison ?

Les cas de modification étant rares inutile de fabriquer une usine à gaz.

Voyez ce fichier (2) et la macro modifiée.

A+

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour lebast, le forum,

Sans faire une usine à gaz on peut insérer automatiquement les lignes manquantes.

Avec ce code en fin de macro :

'---nouvelle définition de LignesSemaines---
If manquant Then
  MsgBox manquant & " ligne(s) manquante(s) insérée(s) sur les semaines des feuilles." _
  & vbLf & "Le nom LignesSemaines passe de " & nlig & " à " & nlig + manquant & "."
  ThisWorkbook.Names.Add "LignesSemaines", nlig + manquant
  For Each w In Worksheets
    If IsDate("1/" & w.Name) Then
      For i = w.UsedRange.Rows.Count To 1 Step -1
        If Cells(i, 1) Like "Semaine*" Then Rows(i + 2).Resize(manquant).Insert
      Next
    End If
  Next
  GoTo 1 'nouveau passage
End If

Fichier (3), voyez le nom défini LignesSemaines.

Nota : pour que les cellules fusionnées en colonne A englobent bien les semaines LignesSemaines doit être au moins égal à 2.

Bonne journée.

 

[lebast]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour job75,

le fichier fonctionne et je te remercie de ton aide.

le complément de code transmis ne correspond pas totalement au besoin
Je m'explique, A terme il y aura plusieurs onglet Juin, Juillet etc ...
le problème que je rencontre est :
si sur juillet le nombre de ligne n'est pas suffisant, cela augmente le nombre de ligne sur toutes les feuilles du classeurs.
et donc efface une partie des données de juin.
Ce code ne peut il pas s'appliquer uniquement à un regroupement de jour correspondant à une semaine ? un groupement de ligne en réalité ?

Encore une fois merci pour ton aide

Bastien

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour lebast,

si sur juillet le nombre de ligne n'est pas suffisant, cela augmente le nombre de ligne sur toutes les feuilles du classeurs.

Evidemment, et le nombre de lignes est mémorisé dans un nom défini.

et donc efface une partie des données de juin.

Pas du tout, où avez-vous vu ça ?

Ce code ne peut il pas s'appliquer uniquement à un regroupement de jour correspondant à une semaine ? un groupement de ligne en réalité ?

Non pas avec ce code (qui est simple), mais avec une usine à gaz sans doute oui.

A+

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Re,

Bah en relisant le code précédent je vois que j'avais oublié les w ici :

If w.Cells(i, 1) Like "Semaine*" Then W.Rows(i + 2).Resize(manquant).Insert

Utilisez la macro de ce fichier (4).

A+

 

[job75]

Re : Renvoyer des donnéesdan sun tableau en fonction d'une date - MACRO

Bonjour lebast, le forum,

Vous avez eu raison d'insister, on peut assez facilement ajuster le nombre de lignes de chaque semaine :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsDate("1/" & Sh.Name) Then Exit Sub
Dim ncol%, lig&, nligsem&, maxi&, col%, dat&, n As Variant, i&, j%
ncol = 3 'nombre de colonnes d'un jour
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
  On Error Resume Next: .ShowAllData: On Error GoTo 0
  .[Z1] = 1
  .UsedRange.Columns(26).DataSeries 'numérotation des lignes
  .UsedRange.Sort .[A1], Header:=xlYes 'tri sur les dates
  For lig = Range("A1", Sh.UsedRange).Rows.Count To 1 Step -1
    If Cells(lig, 1) Like "Sem*" Then
      nligsem = Cells(lig, 1).MergeArea.Count - 1
      Cells(lig + 1, 2).Resize(nligsem, 5 * ncol) = "" 'RAZ
      maxi = 2 'au moins 2 lignes
      For col = 2 To 5 * ncol + 1 Step ncol
        dat = Cells(lig, col)
        n = Application.Match(dat, .[A:A], 0)
        If IsNumeric(n) Then
          i = 1
          Do
            If i > maxi Then maxi = i
            If i > nligsem Then
              Rows(lig + i - 1).Insert
              Rows(lig + i).Copy Rows(lig + i - 1)
              nligsem = nligsem + 1
            End If
            For j = 1 To ncol
              Cells(lig + i, col + j - 1) = .Cells(n, j + 1)
            Next j
            i = i + 1: n = n + 1
          Loop While .Cells(n, 1) = dat
        End If
      Next col
      If nligsem > maxi Then Rows(lig + maxi + 1).Resize(nligsem - maxi).Delete
    End If
  Next lig
  .UsedRange.Sort .[Z1], xlAscending 'ordre initial
  .[Z:Z] = ""
  With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

Le nombre de lignes d'une semaine doit être au moins de 2, c'est pourquoi maxi est initialisé à 2.

Edit : vous aurez compris que ce sont les cellules fusionnées en colonne A qui permettent de connaître le nombre de lignes, ceci grâce à .MergeArea.Count.

Chaque cellule fusionnée doit englober la ligne des dates.

Fichier (5).

A+