XL 2019 Incrémenter fichier automatiquement

Q

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
Solution
job75
Bonjour Quicksland, le forum,

J'ai complètement revu la macro car elle était devenue trop tarabiscotée :
VB: 
Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, Base1 As Range, nlig1&, Base2 As Range, nlig2&, Base3 As Range, nlig3, Signature As Range, nlig4&, deb As Range, nlig&, i&, x$, j&, h&
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set Base1 = Sheets("MODELE").[A1:M8]: nlig1 = Base1.Rows.Count
Set Base2 = Sheets("MODELE").[A9:M22]: nlig2 = Base2.Rows.Count
Set Base3 = Sheets("MODELE").[A23:M42]: nlig3 = Base3.Rows.Count
Set Signature = Sheets("MODELE").[A26:M42]: nlig4 = Signature.Rows.Count
Application.ScreenUpdating...
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Dans la feuille source il a été ajouté (SCOL) derrière ADULTE, MATERNELLE, PRIMAIRE.

Donc remplacez :
VB: 
a = Array("ADULTE", "MATERNELLE", "PRIMAIRE")
par :
VB: 
a = Array("*ADULTE*", "*MATERNELLE*", "*PRIMAIRE*")
 
Vote positif 0 Vote négatif
Q

Quicksland

XLDnaute Occasionnel
job75 à dit:
Dans la feuille source il a été ajouté (SCOL) derrière ADULTE, MATERNELLE, PRIMAIRE.

Donc remplacez :
VB: 
a = Array("ADULTE", "MATERNELLE", "PRIMAIRE")
par :
VB: 
a = Array("*ADULTE*", "*MATERNELLE*", "*PRIMAIRE*")
Cliquez pour agrandir...
Ok ça marche sauf pour les 5 tableaux du bas " laboratoire, résidence Bosquet , résidence Prayon ,restauration du Tilloy et restauration Salamandre
Merci
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Quicksland,

Bon j'ai trouvé une solution avec un test complémentaire de sécurité recherchant le mot "Menu" :
VB: 
        '---test complémentaire de sécurité---
        If Not flag Then
            Set c1 = .Columns(1).Find("Menu", c)
            If Not c1 Is Nothing Then
                mem = c1(1, 2) 'mémorise le menu
                c1(1, 2) = "PRIMAIRE" 'pour forcer l'exécution
                GoTo 1 'relance la recherche
            End If
        End If
La variable flag permet de repérer les cas où ce complément doit s'exécuter.

A+
 

Pièces jointes

  • REPARTITION _ LIVRAISON.xlsm
    93.8 KB · Affichages: 7
  • LIVRAISON.xlsx
    18.2 KB · Affichages: 1
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Quicksland, le forum,

J'ai complètement revu la macro car elle était devenue trop tarabiscotée :
VB: 
Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, Base1 As Range, nlig1&, Base2 As Range, nlig2&, Base3 As Range, nlig3, Signature As Range, nlig4&, deb As Range, nlig&, i&, x$, j&, h&
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set Base1 = Sheets("MODELE").[A1:M8]: nlig1 = Base1.Rows.Count
Set Base2 = Sheets("MODELE").[A9:M22]: nlig2 = Base2.Rows.Count
Set Base3 = Sheets("MODELE").[A23:M42]: nlig3 = Base3.Rows.Count
Set Signature = Sheets("MODELE").[A26:M42]: nlig4 = Signature.Rows.Count
Application.ScreenUpdating = False
UsedRange.Delete xlUp 'RAZ
PageSetup.PrintArea = Base1.EntireColumn.Address 'zone d'impression
PageSetup.Zoom = False
PageSetup.FitToPagesWide = 1 '1 page en largeur
Set deb = [A1]
With Workbooks.Open(fichier).Sheets(1).UsedRange
    nlig = .Rows.Count
    For i = 1 To nlig
        x = LCase(.Cells(i, 1))
        If x Like "*point de livraison*" Then
            Base1.Copy deb
            If deb.Row > 1 Then HPageBreaks.Add deb 'saut de page horizontal
            deb(5, 4) = .Cells(i - 1, 2) 'date
            deb(6, 4) = .Cells(i, 2) 'point de livraison
            deb(2, 11) = .Cells(i, 2)
            deb(6, 7) = .Cells(i, 4) 'ville
            deb(7, 4) = .Cells(i + 1, 2)
            Set deb = deb(nlig1 + 1)
        ElseIf x Like "*menu*" Then
            Base2.Copy deb
            deb(1, 3) = .Cells(i, 2)
            For j = i + 2 To nlig
                x = LCase(.Cells(j, 1))
                If x Like "*menu*" Or x Like "*cumul*" Or x Like "*livraison*" Then Exit For
            Next j
            h = j - i - 2
            deb(3, 2).Resize(h) = .Cells(i + 2, 1).Resize(h).Value
            deb(3, 6).Resize(h) = .Cells(i + 2, 2).Resize(h).Value
            deb(3, 8).Resize(h, 3) = .Cells(i + 2, 3).Resize(h, 3).Value
            Set deb = deb(nlig2 + 1)
            i = j - 1
            If x Like "*livraison*" Or j > nlig Then Signature.Copy deb(0): Set deb = deb(nlig4)
        ElseIf x Like "*cumul*" Then
            Base3.Copy deb
            deb(2, 2) = .Cells(i + 1, 1)
            deb(2, 6) = .Cells(i + 1, 2)
            deb(2, 8).Resize(, 3) = .Cells(i + 1, 3).Resize(, 3).Value
            If Not IsDate(.Cells(i + 2, 2)) Then
                deb(3, 2) = .Cells(i + 2, 1)
                deb(3, 6) = .Cells(i + 2, 2)
                deb(3, 8).Resize(, 3) = .Cells(i + 2, 3).Resize(, 3).Value
            End If
            Set deb = deb(nlig3 + 1)
        End If
    Next i
    .Parent.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
On remarquera que je divise le tableau de la feuille "MODELE" en 3 parties Base1 Base2 Base3.

La zone Signature est seule copiée quand c'est nécessaire (point de livraison LABORATOIRE).

Edit : ajouté la mise en page pour l'impression et les sauts de page.

A+
 

Pièces jointes

  • REPARTITION _ LIVRAISON(1).xlsm
    31.9 KB · Affichages: 5
  • LIVRAISON.xlsx
    26.6 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
Solution
Q

Quicksland

XLDnaute Occasionnel
job75 à dit:
Bonjour Quicksland, le forum,

J'ai complètement revu la macro car elle était devenue trop tarabiscotée :
VB: 
Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, Base1 As Range, nlig1&, Base2 As Range, nlig2&, Base3 As Range, nlig3, Signature As Range, nlig4&, deb As Range, nlig&, i&, x$, j&, h&
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set Base1 = Sheets("MODELE").[A1:M8]: nlig1 = Base1.Rows.Count
Set Base2 = Sheets("MODELE").[A9:M22]: nlig2 = Base2.Rows.Count
Set Base3 = Sheets("MODELE").[A23:M42]: nlig3 = Base3.Rows.Count
Set Signature = Sheets("MODELE").[A26:M42]: nlig4 = Signature.Rows.Count
Application.ScreenUpdating = False
UsedRange.Delete xlUp 'RAZ
PageSetup.PrintArea = Base1.EntireColumn.Address 'zone d'impression
PageSetup.Zoom = False
PageSetup.FitToPagesWide = 1 '1 page en largeur
Set deb = [A1]
With Workbooks.Open(fichier).Sheets(1).UsedRange
    nlig = .Rows.Count
    For i = 1 To nlig
        x = LCase(.Cells(i, 1))
        If x Like "*point de livraison*" Then
            Base1.Copy deb
            If deb.Row > 1 Then HPageBreaks.Add deb 'saut de page horizontal
            deb(5, 4) = .Cells(i - 1, 2) 'date
            deb(6, 4) = .Cells(i, 2) 'point de livraison
            deb(2, 11) = .Cells(i, 2)
            deb(6, 7) = .Cells(i, 4) 'ville
            deb(7, 4) = .Cells(i + 1, 2)
            Set deb = deb(nlig1 + 1)
        ElseIf x Like "*menu*" Then
            Base2.Copy deb
            deb(1, 3) = .Cells(i, 2)
            For j = i + 2 To nlig
                x = LCase(.Cells(j, 1))
                If x Like "*menu*" Or x Like "*cumul*" Or x Like "*livraison*" Then Exit For
            Next j
            h = j - i - 2
            deb(3, 2).Resize(h) = .Cells(i + 2, 1).Resize(h).Value
            deb(3, 6).Resize(h) = .Cells(i + 2, 2).Resize(h).Value
            deb(3, 8).Resize(h, 3) = .Cells(i + 2, 3).Resize(h, 3).Value
            Set deb = deb(nlig2 + 1)
            i = j - 1
            If x Like "*livraison*" Or j > nlig Then Signature.Copy deb(0): Set deb = deb(nlig4)
        ElseIf x Like "*cumul*" Then
            Base3.Copy deb
            deb(2, 2) = .Cells(i + 1, 1)
            deb(2, 6) = .Cells(i + 1, 2)
            deb(2, 8).Resize(, 3) = .Cells(i + 1, 3).Resize(, 3).Value
            If Not IsDate(.Cells(i + 2, 2)) Then
                deb(3, 2) = .Cells(i + 2, 1)
                deb(3, 6) = .Cells(i + 2, 2)
                deb(3, 8).Resize(, 3) = .Cells(i + 2, 3).Resize(, 3).Value
            End If
            Set deb = deb(nlig3 + 1)
        End If
    Next i
    .Parent.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
On remarquera que je divise le tableau de la feuille "MODELE" en 3 parties Base1 Base2 Base3.

La zone Signature est seule copiée quand c'est nécessaire (point de livraison LABORATOIRE).

Edit : ajouté la mise en page pour l'impression et les sauts de page.

A+
Cliquez pour agrandir...
Bonjour Job75

Je reviens vers toi pour un nouveau fichier

Le premier fonctionne parfaitement et je te remercie ;)

Dans le premier fichier ( effectifs réel par point de livraison ) je souhaite récupéré les valeurs en jaune pour incrémenter le fichier ( VINAIGRETTE AUTOMATIQUE)

Je te remercie d'avance
 

Pièces jointes

  • Effectifs réels par point de livraison.xlsx
    14.4 KB · Affichages: 2
  • VINAIGRETTE AUTOMATIQUE.xlsm
    27.3 KB · Affichages: 2
Vote positif 0 Vote négatif
Q

Quicksland

XLDnaute Occasionnel
job75 à dit:
Bonjour Quicksland,

Ce n'est plus le même problème, comme le préconise la Charte du forum créez une nouvelle discussion.

Je n'aurai pas le temps de m'en occuper car je dois m'absenter quelques jours.

A+
Cliquez pour agrandir...
Re
Ok pas de soucis 👍

Comme c'était un peu dans le même genre je pensai que c'était plus facile pour toi ;)
et puis ce n'était pas urgent

Je te remercie malgré tout
 
Vote positif 0 Vote négatif

Discussions similaires

Q
  • Question
XL 2019 incrémentation fichier automatiquement
Réponses
14
Affichages
555
Quicksland
Q
ArnaudSi
  • Question
XL pour MAC Besoin d'aide pour calculer automatiquement un jour de livraison dans Excel
Réponses
10
Affichages
309
ArnaudSi
ArnaudSi
S
  • Résolu(e)
XL 2019 Récupération valeurs à partir d'un fichier source
Réponses
7
Affichages
450
sum01
S
M
  • Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
557
ManuXZ
M
M
  • Résolu(e)
Power Query Convertir un fichier PdF en Excel et restitution d'un état de synthèse
Réponses
10
Affichages
453
Merlin258413
M
P
  • Question
Microsoft 365 Automatisation avec création de fichier et d'onglets en fonction des valeurs
2
Réponses
15
Affichages
853
pene
P
A
  • Question
XL 2019 Copier une plage dans un fichier fermé en VBA
2
Réponses
21
Affichages
1 K
Amilo
A
L
  • Question
XL 2016 Gestion de stock excel
Réponses
6
Affichages
2 K
Lily37
L
B
  • Question
XL 2016 Formule avec plusieurs conditions pour planning heures annuelles
Réponses
5
Affichages
397
fanfan38
fanfan38
Q
  • Question
Autres Soucis de récupération de valeurs
Réponses
5
Affichages
965
Quicksland
Q

Membres actuellement en ligne

3 membres et 44 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 219
Membres
103 158
dernier inscrit
laufin