Excel - Découper des fichiers (VBA)

Bonjour,

Avant de poster ce message, j'ai regardé les postes similaires qui existaient sur le sujet. Malheureusement, étant donné qu'il s'agit souvent de demande particulière, j'ai difficilement obtenu la réponse à ma question.

J'aimerais découper dans un fichier global des fichiers à envoyer à chaque manager (environ 40 fichiers).

Il faudrait que la macro puisse découper les fichiers en fonction des managers (colonnes L, M et N) car un collaborateur peut avoir soit 1 manager ou 3 managers. Ainsi, si un salarié a 3 managers différents (différents niveaux), il faut que ces 3 managers puissent voir les informations sur le salarié en question.

Le fichier en question comporte environ 400 lignes.

Je mets en pièce jointe le modèle qui vous permettra de m'aider.

D'avance merci beaucoup, je reste à votre disposition pour tout renseignement complémentaire.

Simon

Bonjour,

tu as une application toute faite ici

https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466

le dispatch se fait en utilisant un modèle

sauf qu'en effet je ne m'appuie que sur une colonne

il faudrait voir comment l'utiliser avec 3 colonnes

Voici une adaptation du code

Option Explicit
Public critere%

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

    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, 2).End(xlUp).CurrentRegion

    Set dico1 = CreateObject("Scripting.Dictionary")
    For i = LBound(data) + 1 To UBound(data) ' hors en-tête
        dico1(data(i, 11)) = "" ' colonne L (écart de 1 car le tableau commence colonne 2)
        dico1(data(i, 12)) = "" ' colonne M
        dico1(data(i, 13)) = "" ' colonne N
    Next

    Application.ScreenUpdating = False
    For Each cle1 In dico1.Keys
        If cle1 <> "" Then
            result1 = filtreArray(data, 11, 12, 13, cle1)
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
            wb.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
            wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
            wb.Close
            Set wb = Nothing
        End If
    Next
    Application.ScreenUpdating = True

    MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub

et

Function filtreArray(Tbl, col1, col2, col3, param)
Dim i%, j%, k%, n%
    For i = 1 To UBound(Tbl)
        If Tbl(i, col1) = param Then n = n + 1
        If Tbl(i, col2) = param Then n = n + 1
        If Tbl(i, col3) = 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, col1) = param Or Tbl(i, col2) = param Or Tbl(i, col3) = 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

Bonjour,

Merci beaucoup, cela fonctionne très bien.

J'ai juste remarqué que la colonne K était aussi concernée par ce découpage.

J'ai essayé de modifier le code mais je n'ai pas réussis.

Est-il possible de modifier le code en conséquence svp ?

Merci

Simon

Il faut donc ajouter 10 qui correspond à la colonne K du tableau qui commence à la deuxième colonne.

ET ajouter une quatrième colonne au filtre

Option Explicit
Public critere%

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

    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, 2).End(xlUp).CurrentRegion

    Set dico1 = CreateObject("Scripting.Dictionary")
    For i = LBound(data) + 1 To UBound(data) ' hors en-tête
        dico1(data(i, 10)) = "" ' colonne K
        dico1(data(i, 11)) = "" ' colonne L (écart de 1 car le tableau commence colonne 2)
        dico1(data(i, 12)) = "" ' colonne M
        dico1(data(i, 13)) = "" ' colonne N
    Next

    Application.ScreenUpdating = False
    For Each cle1 In dico1.Keys
        If cle1 <> "" Then
            result1 = filtreArray(data, 10, 11, 12, 13, cle1)
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
            wb.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
            wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
            wb.Close
            Set wb = Nothing
        End If
    Next
    Application.ScreenUpdating = True

    MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub

et

Function filtreArray(Tbl, col1, col2, col3, col4, param)
Dim i%, j%, k%, n%
    For i = 1 To UBound(Tbl)
        If Tbl(i, col1) = param Then n = n + 1
        If Tbl(i, col2) = param Then n = n + 1
        If Tbl(i, col3) = param Then n = n + 1
        If Tbl(i, col4) = 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, col1) = param Or Tbl(i, col2) = param Or Tbl(i, col3) = param Or Tbl(i, col4) = 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

C'est parfait !! Merci beaucoup

Seul petit problème qui persiste, quand je copie/colle mes données (400 lignes) ça bloque... j'arrive uniquement à découper quand je mets quelques lignes

Savez-vous pourquoi ?

Je suis surpris, mais on peut passer les variables % (integer) en long

Je vais faire un test

Aucun problème, même avec 5000 lignes.

Tes données commencent bien en colonne 2 ?

Il n'y a pas de lignes vierges ? (sauf au-dessus de tout)

J'ai testé avec les données que tu as inséré et en effet ça fonctionne très bien.

Non, j'ai vraiment copié/collé mes valeurs dans le tableau directement en ne modifiant rien.

Ca me met "erreur d'exécution '13' : incompatibilité de type".

Simon

EDIT :

J'avais un #N/A qui bloquait apparemment ...

Bonjour,

Je me permets de relancer ce sujet pour savoir s'il était possible de garder les cellules surlignées en jaune dans mon fichier source dans mes fichiers découpés ? En d'autres mots, transférer aussi la mise en forme des cellules du fichier source vers les fichiers découpés.

Merci d'avance pour vos réponses,

Bonne journée

Est-ce que le surlignement en jaune est manuel ? ou lié à une formule dans une MFC ?

Je pense qu'il faudrait essayer la chose suivante :

• ajouter une colonne avec un indicateur
• ajouter une MFC qui prend en compte l'indicateur pour afficher le surlignement
• mettre dans le modèle le même mécanisme : colonne et MFC

L'avantage serait que le script resterait très optimisé, car le report manuel de la mise en forme risque de ralentir terriblement le processus.

Bonjour Steelson,

Merci pour ton retour.

Le surlignement n'est pas manuel, il est issu d'une macro qui compare deux bases de données et surligne en jaune les écarts dans une des deux bases de données.

En termes d'expertise, j'avoue être un peu limité à ce niveau, pourrais-tu me guide s'il te plait ?

Merci d'avance

Bonne journée

Simon17 a écrit :

Le surlignement n'est pas manuel, il est issu d'une macro qui compare deux bases de données et surligne en jaune les écarts dans une des deux bases de données.

Dans ce cas, il faudrait que la macro de comparaison ajoute plutôt une colonne qui indiqué l'écart, dans ce cas ce sera plus simple de reporter cet écart et de surligner en jaune avec une MFC.