Dispatcher un état ... puis compiler les retours

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,

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 !

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

@ bientôt

LouReeD

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

Et moi qui aie voulu me prendre pour dhany !

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

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.

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 !

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

Perplexe car je ne vois pas de où cela vient.

Cela se produit chez moi uniquement vers la droite, pas de changement en vertical.

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

Merci Eriiiic pour tes suggestions.

Je vais aussi ajouter une possibilité que le fichier généré soit formaté comme le fichier d'origine.

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.

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 :

Merci pour vos recommandations.

Voici une nouvelle version plus intéressante :

  • choix du critère par REfEdit (c'est une première pour moi)
  • les données sont exportés selon le modèle se trouvant dans le même dossier (Model.xlsx)
4model.xlsx (8.25 Ko)
Rechercher des sujets similaires à "dispatcher etat puis compiler retours"