XL 2019 Incrémenter fichier automatiquement

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

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

Dernière édition:
Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
Solution
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

Vote positif 0 Vote négatif
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Q
  • Question Question
XL 2019 incrémentation fichier automatiquement
Réponses
14
Affichages
751
Quicksland
Q
ArnaudSi
  • Question Question
XL pour MAC Besoin d'aide pour calculer automatiquement un jour de livraison dans Excel
Réponses
10
Affichages
1 K
ArnaudSi
ArnaudSi
A
  • Résolu(e)
Microsoft 365 NB.SI sous condition_fusionner deux formules
Réponses
10
Affichages
395
job75
job75
D
  • Question Question
Microsoft 365 Mise à jour des références / liens depuis un sharepoint
Réponses
3
Affichages
352
Dégé59
D
M
  • Question Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
1 K
ManuXZ
M
S
  • Résolu(e)
XL 2019 Récupération valeurs à partir d'un fichier source
Réponses
7
Affichages
794
sum01
S
P
  • Résolu(e)
XL 2021 Requête API - VBA Excel - Parse JSON
Réponses
2
Affichages
486
picc
P
G
  • Question Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
341
sylvanu
sylvanu
O
  • Question Question
XL 2019 erreur de valeur sur formule
2
Réponses
18
Affichages
1 K
olivier1984
O
P
  • Question Question
Microsoft 365 Automatisation avec création de fichier et d'onglets en fonction des valeurs
2
Réponses
15
Affichages
1 K
pene
P
M
  • Résolu(e)
Power Query Convertir un fichier PdF en Excel et restitution d'un état de synthèse
Réponses
10
Affichages
1 K
Merlin258413
M
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
1 K
Pac41240
P
B
  • Question Question
XL 2016 Formule avec plusieurs conditions pour planning heures annuelles
Réponses
5
Affichages
662
fanfan38
fanfan38
A
  • Question Question
XL 2019 Copier une plage dans un fichier fermé en VBA
2
Réponses
21
Affichages
2 K
Amilo
A
D
  • Résolu(e)
Microsoft 365 Macro pour rafraîchir les liaisons
Réponses
11
Affichages
551
AtTheOne
AtTheOne
T
  • Question Question
Autres Macro graphique excel
Réponses
4
Affichages
812
talbimassinissa
T
Tomasisco21
  • Question Question
Microsoft 365 Fichier automatisé VBA - Template Budget project
Réponses
5
Affichages
926
Tomasisco21
Tomasisco21
oguruma
POWERQUERY :: Ranking par catégorie :: TopN variable d'une liste
Réponses
0
Affichages
418
oguruma
oguruma
100kibou
  • Question Question
XL 2021 Intégration de données et userfom
Réponses
9
Affichages
926
100kibou
100kibou
oguruma
POWERQUERY :: Récupérer les attributs d'un fichier, Parcourir un dossier, Récupérer le contenu d'un fichier texte, Vérifier la présence d'un fichier
Réponses
0
Affichages
733
oguruma
oguruma
Retour