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.