XL 2019 Incrémenter fichier automatiquement

Quicksland

XLDnaute Occasionnel
Bonjour le forum ;)

J'ai un fichier Excel que je récupère d'un logiciel tiers (REPARTITION _ LIVRAISON SOURCE) non structuré mais qui reste identique chaque jours

avec ce fichier je souhaiterai pouvoir alimenter automatiquement le fichier(REPARTITION _ LIVRAISON 2) qui celui ci me convient parfaitement

toutes les cellules jaune dans (REPARTITION _ LIVRAISON SOURCE) alimente toutes les cellules jaune du fichier (REPARTITION _ LIVRAISON 2)

Je vous remercie
 

Pièces jointes

  • Copie de REPARTITION _ LIVRAISON SOURCE.xlsx
    31.4 KB · Affichages: 16
  • REPARTITION _ LIVRAISON 2.xlsm
    72.2 KB · Affichages: 10

job75

XLDnaute Barbatruc
Bonjour Quicksland, natorp, le forum,

Téléchargez les 2 fichiers joints dans le même dossier (le bureau).

La macro du bouton :
VB:
Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, P As Range, nlig&, c As Range, n%, a, b, i%, c3 As Range, c1 As Range, c2 As Range, Q As Range, h%
fichier = ThisWorkbook.Path & "\REPARTITION _ LIVRAISON SOURCE.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set P = [B1:L67] 'tableau de base
nlig = P.Rows.Count
Application.ScreenUpdating = False
P.Offset(nlig).Resize(Rows.Count - nlig).Delete xlUp 'RAZ
With Workbooks.Open(fichier).Sheets(1)
    Set c = .Cells(1)
    For n = 1 To Application.CountIf(.Columns(1), "Point de livraison")
        If n > 1 Then
            P.Copy P.Offset(nlig) 'copier-coller
            Set P = P.Offset(nlig)
        End If
        P(5, 3).Resize(3) = ""
        P.Rows(11).Resize(8, 8) = ""
        P.Rows(22).Resize(11, 8) = ""
        P.Rows(36).Resize(11, 8) = ""
        P.Rows(49).Resize(2, 8) = ""
        Set c = .Columns(1).Find("Point de livraison", c, xlValues, xlWhole)
        P(2, 10) = Replace(c(1, 2), " ND ", " NOTRE DAME ") 'lieu
        P(5, 3) = c(0, 2) 'date
        P(6, 3) = c(1, 2) 'point de livraison
        P(7, 3) = c(2, 2) 'camion
        Set c3 = .Columns(1).Find("*Cumul*", c)(2)
        '---les 3 zones des copies---
        a = Array("ADULTE", "MATERNELLE", "PRIMAIRE")
        b = Array(11, 22, 36) 'n° de la 1ère ligne à remplir
        For i = 0 To UBound(a)
            Set c1 = .Columns(2).Find(a(i), c(1, 2))
            If Not c1 Is Nothing Then If c1.Row > c3.Row Or c1.Row < c.Row Then Set c1 = Nothing
            If Not c1 Is Nothing Then
                Set c2 = .Columns(1).Find("Plats", c1(3, 0))
                If c2 Is Nothing Then Set c2 = c3
                If c2.Row > c3.Row Or c2.Row < c.Row Then Set c2 = c3
                Set Q = .Range(c1(3, 0), c2(-1))
                h = Q.Rows.Count
                P(b(i), 1).Resize(h) = Application.Trim(Q.Value) 'SUPPRESPACE
                P(b(i), 5).Resize(h) = Q.Columns(2).Value
                P(b(i), 7).Resize(h) = Application.Trim(Q.Columns(3).Value)
                P(b(i), 8).Resize(h) = Q.Columns(4).Value
            End If
        Next i
        '---Cumul des plats non conditionnés---
        Set Q = c3.Resize(2)
        P(49, 1).Resize(2) = Q.Value
        P(49, 5).Resize(2) = Q.Columns(2).Value
        P(49, 7).Resize(2) = Q.Columns(3).Value
        P(49, 8).Resize(2) = Q.Columns(4).Value
        P(50, 7) = Replace(P(50, 7), "Effectif prévu :", "")
    Next n
    .Parent.Close False
End With
End Sub
Elle n'a pas été facile à mettre au point.

Edit : il y avait une coquille au niveau des effacements, j'ai corrigé.

A+
 

Pièces jointes

  • REPARTITION _ LIVRAISON(1).xlsm
    28.1 KB · Affichages: 0
  • REPARTITION _ LIVRAISON SOURCE.xlsx
    31.7 KB · Affichages: 1
Dernière édition:

Quicksland

XLDnaute Occasionnel
Bonjour JOb75

C'est du très bon boulot et je te remercie pour ton aide 🙏

Malheureusement il y a un petit soucis ...

les 5 tableaux ( LABORATOIRE, BOSQUET , RPA ,ST et FJT en bas du fichier ne sont pas identique au autres et l'incrémentation automatique n'est pas bonne

Alors soit tu as la possibilité de modifier ou alors tu garde le fichier (REPARTITION _ LIVRAISON SOURCE) pour alimenter le nouveau fichier ci joint (LABO BOSQUET RPA ST FJT)

Je te remercie d'avance ;)
 

Pièces jointes

  • LABO BOSQUET RPA ST FJT.xlsx
    18.5 KB · Affichages: 3
Dernière édition:

job75

XLDnaute Barbatruc
Les 5 derniers tableaux n'ont rien de spécial, je les ai traités comme tous les autres.

Maintenant on peut supprimer les lignes vides et les sous-tableaux inutiles.

Pour cela il faut utiliser une feuille MODELE qui mémorise le tableau de base.

Voyez ce fichier (2) et la nouvelle macro :
VB:
Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, Base As Range, nlig&, c As Range, n%, Prem As Range, a, b, i%, c3 As Range, c1 As Range, c2 As Range, R As Range, h%
fichier = ThisWorkbook.Path & "\REPARTITION _ LIVRAISON SOURCE.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set Base = Sheets("MODELE").[A1:L67] 'tableau de base
nlig = Base.Rows.Count
Application.ScreenUpdating = False
UsedRange.Delete xlUp 'RAZ
With Workbooks.Open(fichier).Sheets(1)
    Set c = .Cells(1)
    For n = 0 To Application.CountIf(.Columns(1), "Point de livraison") - 1
        Set Prem = Cells(n * nlig + 1, 1) '1ère cellule du tableau
        IIf(n, Base, Base.EntireColumn).Copy Prem 'copier-coller
        Set c = .Columns(1).Find("Point de livraison", c, xlValues, xlWhole)
        Prem(2, 11) = Replace(c(1, 2), " ND ", " NOTRE DAME ") 'lieu
        Prem(5, 4) = c(0, 2) 'date
        Prem(6, 4) = c(1, 2) 'point de livraison
        Prem(7, 4) = c(2, 2) 'camion
        Set c3 = .Columns(1).Find("*Cumul*", c)(2)
        '---les 3 zones des copies---
        a = Array("ADULTE", "MATERNELLE", "PRIMAIRE")
        b = Array(11, 22, 36) 'n° de la 1ère ligne à remplir
        For i = 0 To UBound(a)
            Set c1 = .Columns(2).Find(a(i), c(1, 2))
            If Not c1 Is Nothing Then If c1.Row > c3.Row Or c1.Row < c.Row Then Set c1 = Nothing
            If Not c1 Is Nothing Then
                Set c2 = .Columns(1).Find("Plats", c1(3, 0))
                If c2 Is Nothing Then Set c2 = c3
                If c2.Row > c3.Row Or c2.Row < c.Row Then Set c2 = c3
                Set R = .Range(c1(3, 0), c2(-1))
                h = R.Rows.Count
                Prem(b(i), 2).Resize(h) = Application.Trim(R.Value) 'SUPPRESPACE
                Prem(b(i), 6).Resize(h) = R.Columns(2).Value
                Prem(b(i), 8).Resize(h) = Application.Trim(R.Columns(3).Value)
                Prem(b(i), 9).Resize(h) = R.Columns(4).Value
            End If
        Next i
        '---Cumul des plats non conditionnés---
        Set R = c3.Resize(2)
        Prem(49, 2).Resize(2) = R.Value
        Prem(49, 6).Resize(2) = R.Columns(2).Value
        Prem(49, 8).Resize(2) = R.Columns(3).Value
        Prem(49, 9).Resize(2) = R.Columns(4).Value
        Prem(50, 8) = Replace(Prem(50, 7), "Effectif prévu :", "")
    Next n
    .Parent.Close False
End With
'---suppression des lignes vides inutiles---
On Error Resume Next 'si aucune SpecialCell
Columns(1).SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
Columns(1).ClearContents 'supprime les formule
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
 

Pièces jointes

  • REPARTITION _ LIVRAISON(2).xlsm
    33.1 KB · Affichages: 1
  • REPARTITION _ LIVRAISON SOURCE.xlsx
    31.7 KB · Affichages: 1
Dernière édition:

job75

XLDnaute Barbatruc
Pour terminer j'ai bien vu que quand la 2ème ligne de "Cumul des plats non conditionnés" n'existe pas vous ne vouliez pas qu'elle s'affiche.

Avec les formules en colonne A il est facile de la supprimer, mais alors la bordure inférieure posait problème.

Je l'ai résolu avec une MFC sur la plage B49:L59 de la feuille MODELE, voyez ce fichier (3).
 

Pièces jointes

  • REPARTITION _ LIVRAISON(3).xlsm
    33.2 KB · Affichages: 5
  • REPARTITION _ LIVRAISON SOURCE.xlsx
    31.7 KB · Affichages: 7

Quicksland

XLDnaute Occasionnel
Bonjour Gérard,

C'est du très bon boulot et je te remercie

J'ai plusieurs questions ....

Si dans l'avenir nous livrons une école supplémentaire que doit je modifié ?

Si une ou plusieurs lignes apparait car livraison supplémentaire d'un plat dans le

fichier source au niveau Adulte Maternelle Primaire Laboratoire RPA ST FJT et Bosquet

La encore que doit je modifié ?

Merci pour ton aide
 

job75

XLDnaute Barbatruc
Bonjour Quicksland, le forum,

Il faut bien avoir compris 2 choses.

1) Le nombre de tableaux sources peut être quelconque : la macro recherche en colonne A le texte "Point de livraison", le lieu étant sur la même ligne en colonne B.

2) Le nombre de plats ne doit pas dépasser 8 pour ADULTE, 11 pour MATERNELLE et 11 pour PRIMAIRE.

Sinon il faudra augmenter le nombre de lignes de ces 3 tableaux dans la feuille MODELE et dans la macro :

- modifier la plage Sheets("MODELE").[A1:L67]

- modifier les numéros des lignes 11, 22, 36, 49 et 50.

A+
 

Quicksland

XLDnaute Occasionnel
Bonsoir Gérard,

Un très grand merci pour ta réactivité ta patience et ton aide pour ce fichier

C'est vraiment du très bon boulot 🙏

j'ai une dernière requête ...

Serait il possible que la mise en page se fasse automatiquement ( 1 tableau par page )

Merci pour ton aide
 

job75

XLDnaute Barbatruc
Bonsoir Quicksland,
Serait il possible que la mise en page se fasse automatiquement ( 1 tableau par page )
Pas de problème, voyez ce fichier (4).

J'ai redéfini le tableau Base jusqu'à la colonne M :
VB:
Set Base = Sheets("MODELE").[A1:M67] 'tableau de base
et pour la mise en page il suffit de créer des sauts de page juste après le copier-coller :
VB:
        If n Then
            HPageBreaks.Add Prem 'saut de page horizontal
        Else
            PageSetup.PrintArea = Base.EntireColumn.Address 'zone d'impression
            PageSetup.Zoom = False
            PageSetup.FitToPagesWide = 1 '1 page en largeur
        End If
Visualisez les aperçus avant impression de la commande Fichier-Imprimer.

A+
 

Pièces jointes

  • REPARTITION _ LIVRAISON(4).xlsm
    37.1 KB · Affichages: 6

Quicksland

XLDnaute Occasionnel
Bonsoir Quicksland,

Pas de problème, voyez ce fichier (4).

J'ai redéfini le tableau Base jusqu'à la colonne M :
VB:
Set Base = Sheets("MODELE").[A1:M67] 'tableau de base
et pour la mise en page il suffit de créer des sauts de page juste après le copier-coller :
VB:
        If n Then
            HPageBreaks.Add Prem 'saut de page horizontal
        Else
            PageSetup.PrintArea = Base.EntireColumn.Address 'zone d'impression
            PageSetup.Zoom = False
            PageSetup.FitToPagesWide = 1 '1 page en largeur
        End If
Visualisez les aperçus avant impression de la commande Fichier-Imprimer.

A+
Bonjour ,
Apres une mise a jour du fichier source cela ne fonctionne plus correctement :rolleyes:

Serait il possible pour toi de regarder ce qu'il se passe ?

je te remercie d'avance 👍
 

Pièces jointes

  • REPARTITION _ LIVRAISON(4).xlsm
    37.1 KB · Affichages: 2
  • LIVRAISON.xlsx
    18.2 KB · Affichages: 1

job75

XLDnaute Barbatruc
Bonjour Quicksland,

Il est pourtant évident qu'il faut adapter le nom du fichier source si on le modifie :
VB:
'fichier = ThisWorkbook.Path & "\REPARTITION _ LIVRAISON SOURCE.xlsx" 'chemin à adapter
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
A+
 

Quicksland

XLDnaute Occasionnel
Bonjour Quicksland,

Il est pourtant évident qu'il faut adapter le nom du fichier source si on le modifie :
VB:
'fichier = ThisWorkbook.Path & "\REPARTITION _ LIVRAISON SOURCE.xlsx" 'chemin à adapter
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
A+
Bonjour Job75

Malgré le changement rien y fait ...

Dans le premier fichier c'est le fichier (source ) le deuxième c'est ton fichier qui fonctionne très bien avec le premier

Dans le troisième c'est la mise a jour et le dernier c'est le tien avec la mise a jour

Tu verras il est diffèrent

Merci de regarder
 

Pièces jointes

  • REPARTITION _ LIVRAISON SOURCE.xlsx
    31.7 KB · Affichages: 2
  • REPARTITION _ LIVRAISON.xlsm
    95.7 KB · Affichages: 2
  • LIVRAISON.xlsx
    18.2 KB · Affichages: 3
  • REPARTITION _ LIVRAISON.xlsm
    61.8 KB · Affichages: 3

Discussions similaires

Statistiques des forums

Discussions
299 728
Messages
1 978 785
Membres
206 391
dernier inscrit
patcaudron62