Dispatcher un état ... puis compiler les retours

Pour partager vos applications (Excel, Calc et Google Sheets) avec les autres membres
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'063
Appréciations reçues : 894
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 23 mars 2020, 11:12

Bonjour,

En ces temps de confinement (je précise pour les futurs utilisateurs d' excel2014 sous windows 24 que nous sommes en mars 2020 en pleine pandémie) il n'est pas toujours possible de se partager un même fichier sur serveur. Du reste, confinement ou pas,
  • certaines infrastructures ne le permettent pas;
  • ou bien les utilisateurs sont en mode nomade,
  • ou bien les règles édictées par les DSI ne l’autorisent pas ...
Voici donc une macro assez simple de dispatching d'un fichier selon une colonne contenant le critère de disptaching.
Option Explicit

Sub dispatcher()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant, prov1 As Variant
Dim xl As Excel.Application, wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String
Dim colonne$, critere%

    colonne = Application.InputBox("Entrez la colonne servant de critère de dispatching : ", "Saisie en texte (i.e : A B ...)", Type:=2)
    critere = ActiveSheet.Columns(colonne).Column
    
    racine = Split(ThisWorkbook.Name, ".")(0)
    
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)
    
    data = Cells(Rows.Count, 1).End(xlUp).CurrentRegion

    Set dico1 = CreateObject("Scripting.Dictionary")
    For i = LBound(data) + 1 To UBound(data) ' hors en-tête
        dico1(data(i, critere)) = ""
    Next
    
    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = 1
    
    prov1 = data(1, critere)
    For Each cle1 In dico1.Keys
        Set wb = xl.Workbooks.Add
        data(1, critere) = cle1                      ' pour emmener aussi l'en-tête
        result1 = filtreArray(data, critere, cle1)
        With wb.Sheets(1)
            .Cells(1, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
            .Cells(1, critere).Value = prov1
            .Cells.EntireColumn.AutoFit
        End With
        wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next
    xl.Quit
    Set xl = Nothing
    
    MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub

Function filtreArray(Tbl, col, param)
Dim i%, j%, k%, n%
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then n = n + 1
    Next i
    Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))
    
    j = 0
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then
            j = j + 1
            For k = 1 To UBound(Tbl, 2)
                temp(j, k) = Tbl(i, k)
            Next k
        End If
    Next i
    filtreArray = temp
End Function
Il est aussi possible, une fois le renseignement des informations s'il y a lieu, de compiler l'ensemble des fichiers retournés :
Option Explicit
    
Sub collecter()
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet
Dim MonRepertoire, Repertoire As FileDialog, monFichier$, derL%
  
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1) & "\"
    
    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.ActiveSheet
    Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(MonRepertoire & "*.xlsx")

    Do While monFichier <> ""
        ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
        derL = ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Set wbk2 = Workbooks.Open(MonRepertoire & monFichier)
        wbk2.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Cells.Copy
        ws1.Paste
        Application.DisplayAlerts = False
            wbk2.Close False
        Application.DisplayAlerts = True
        Rows(derL).Delete Shift:=xlUp
        monFichier = Dir
    Loop

    Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Cells(1, 1).Select
    
End Sub
Ce code est le plus simple et le plus générique possible, le parti pris est donc de s'adapter à la structure du document (avec ou sans tableaux structurés).

Beaucoup d'applications sont possibles dans de nombreux domaines :
  • sûreté : nombre de visiteurs sur un site sensible par heure
  • commerce : nombre de contacts/prospects par zone géographique,
  • production : production/site ... à des fins de consolidation et de reporting
  • gestion de personnel : primes d'activités spécifiques, heures de délégation/grève (hé oui !) par atelier
  • éducation : notes de correction de copies, liste de présences, cantine etc.
  • ... et quelques autres !
dispatcher puis compiler.xlsm
(27.31 Kio) Téléchargé 15 fois
1 membre du forum aime ce message.

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
LouReeD
Contributeur
Contributeur
Messages : 7'091
Appréciations reçues : 370
Inscrit le : 14 octobre 2014
Version d'Excel : 2013 FR, 2016 FR
Contact :
Téléchargements : Mes applications

Message par LouReeD » 25 mars 2020, 17:36

Excel 2014 !? on reviens en arrière ?!

@ bientôt

LouReeD
Quelques règles à lire ICI ;;)
______________________________________________________Vous pouvez allez faire un tour sur : Index de "Mes applications" ;;)
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'063
Appréciations reçues : 894
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 25 mars 2020, 17:58

Zut, je voulais faire de l'esprit et c'est raté ...

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
LouReeD
Contributeur
Contributeur
Messages : 7'091
Appréciations reçues : 370
Inscrit le : 14 octobre 2014
Version d'Excel : 2013 FR, 2016 FR
Contact :
Téléchargements : Mes applications

Message par LouReeD » 25 mars 2020, 18:44

Et moi qui aie voulu me prendre pour dhany ! :lol:
Par contre j'ai regardé, et j'avoue ne pas avoir compris le but de cette dernière application...

Une autre question mais qui n'a rien à voir avec celle-ci mais plutôt celle des menu en shape :
A chaque changement de groupe de menu, j'ai le shape qui se déplace vers la droite et le bas de l'écran...
Je crois que c'est inné chez Excel, c'est un peu comme l'import de plusieurs photos, il y a un décalage qui se crée.

Mais là plus spécifiquement, y a t il un moyen "qu'il reste en place" ?

@ bientôt

LouReeD
Quelques règles à lire ICI ;;)
______________________________________________________Vous pouvez allez faire un tour sur : Index de "Mes applications" ;;)
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'063
Appréciations reçues : 894
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 25 mars 2020, 20:53

LouReeD a écrit :
25 mars 2020, 18:44
Par contre j'ai regardé, et j'avoue ne pas avoir compris le but de cette dernière application...
Même dans les grands groupes possédant des ERPs BaaN ou SAP etc. il arrive que des choses essentielles se fassent par excel.
Exemple du relevé des présents pendant des heures de grève : le gestionnaire administration du personnel envoie alors de façon ciblée un état du personnel à chaque manager et compile en retour la situation qu'il consolide et envoie pour la paye. Le fait d'éclater le fichier évite d'avoir un listing de 1000 personnes. Idem pour l'attribution de primes de tutorat ou d'incommodité. Autre cas les itérations concernant les augmentations. Ce sont des exemples vécus.
Et puis j'ai rencontré sur ce forum des demandes similaires.
A contrario, je ne vois pas bien l'intérêt d'éclater par onglet.
LouReeD a écrit :
25 mars 2020, 18:44
Une autre question mais qui n'a rien à voir avec celle-ci mais plutôt celle des menu en shape :
A chaque changement de groupe de menu, j'ai le shape qui se déplace vers la droite et le bas de l'écran...
Je crois que c'est inné chez Excel, c'est un peu comme l'import de plusieurs photos, il y a un décalage qui se crée.
Merci pour ta remarque, j'avoue que je n'ai jamais fait attention ... et que je suis perplexe après avoir revu le code !

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
LouReeD
Contributeur
Contributeur
Messages : 7'091
Appréciations reçues : 370
Inscrit le : 14 octobre 2014
Version d'Excel : 2013 FR, 2016 FR
Contact :
Téléchargements : Mes applications

Message par LouReeD » 25 mars 2020, 21:18

Perplexe dans quel sens ?
Dans le code rien ne le "prévoit" et ça vient d'Excel, ou plutôt cela ne se produit pas chez vous et que ma question est "bizarre" ?

@ bientôt

LouReeD
Quelques règles à lire ICI ;;)
______________________________________________________Vous pouvez allez faire un tour sur : Index de "Mes applications" ;;)
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'063
Appréciations reçues : 894
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 26 mars 2020, 05:00

Perplexe car je ne vois pas de où cela vient.
Cela se produit chez moi uniquement vers la droite, pas de changement en vertical.

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
eriiic
Passionné d'Excel
Passionné d'Excel
Messages : 9'727
Appréciations reçues : 453
Inscrit le : 7 février 2010
Version d'Excel : 2010fr

Message par eriiic » 29 mars 2020, 18:04

Bonjour à tous,

excellente idée, le genre qu'on regrette de ne pas avoir eue :-)
Si je peux me permettre quelques suggestions :

1) lors du Dispatch, j'ai bêtement saisi Livraison et... =>plantage
Bon, on apprend vite, mais tu pourrais passer à une sélection à la souris de l'entête choisi.
Ca permettrait de pouvoir traiter les feuilles qui contiennent plusieurs Tableaux. Ca risque de devenir de plus en plus courant.

2) je verrais bien un Application.Screenupdating = False à la recompilation ;-)
eric
En essayant continuellement, on finit par réussir.
Donc plus ça rate, plus on a de chances que ça marche.
(les Shadoks)

En plus du merci (si si, ça se fait !!!), penser à mettre en résolu. Merci
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'063
Appréciations reçues : 894
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 29 mars 2020, 21:44

Merci Eriiiic pour tes suggestions.
Je vais aussi ajouter une possibilité que le fichier généré soit formaté comme le fichier d'origine.
eriiic a écrit :
29 mars 2020, 18:04
Bon, on apprend vite, mais tu pourrais passer à une sélection à la souris de l'entête choisi.
Bonne idée mais je ne vois pas bien comment le faire ! Sauf à sélectionner d'abord la colonne avant de cliquer sur le bouton.

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
eriiic
Passionné d'Excel
Passionné d'Excel
Messages : 9'727
Appréciations reçues : 453
Inscrit le : 7 février 2010
Version d'Excel : 2010fr

Message par eriiic » 29 mars 2020, 22:53

Je pensais à un simple contrôle RefEdit qui permet de récupérer la ref sélectionnée..
Clic-droit sur la boite à outils pour l'ajouter, il ne doit pas y être par défaut.

Edit : https://bettersolutions.com/vba/controls/refedit.htm
En essayant continuellement, on finit par réussir.
Donc plus ça rate, plus on a de chances que ça marche.
(les Shadoks)

En plus du merci (si si, ça se fait !!!), penser à mettre en résolu. Merci
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message