Exportation base dans plusieurs fichiers et récupération dans une base

Bonjour,

Je dois extraire une base de données en 4 activités dans 4 classeurs différents et après rectifications des différents services remettre à jour la base de données. Sachant que je dois éviter le partage du fichier avec la base de données.

Merci de votre aide pour deux macros . une macro pour l’extraction une autre pour la récupération

ET si possible me donner les explications afin de me permettre de l'appliquer à mon fichier original

Cordialement

Bonjour,

est ce que les 4 activités mentionnées sont "abandon","erreur","oui","retour A/C" ?

à vérifier si les rapports conviennent

Bonjour rbmicho59, Isabelle

Je l'ai traité ne éclatant le résultat par fichiers ...

J'ai pris le critère en colonne 13

Option Explicit
Sub fractionner()
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 critere%

critere = 13

    data = ActiveSheet.Cells(1, 1).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)
        wb.Sheets(1).Cells(1, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
        wb.Sheets(1).Cells(1, critere).Value = prov1
        wb.SaveAs (ThisWorkbook.Path & "\" & cle1 & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next
    xl.Quit
    Set xl = Nothing
    MsgBox "Terminé !"

End Sub

reste à faire la re-compilation des fichiers.

Pour re-collecter les données

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range

    Dim chemin$, monFichier$

Sub collecter()

    ' à modifier ...
    chemin = ThisWorkbook.Path & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.Sheets(1)
    ws1.Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsx")

    Do While monFichier <> ""
        If Not monFichier Like "*.xlsm" Then
            Set wbk2 = Workbooks.Open(chemin & monFichier)
            Set ws2 = wbk2.Sheets(1)
            Set rng2 = ws2.Cells(1).CurrentRegion
            rng2.Offset(1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count).Copy
            Set rng1 = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            rng1.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            wbk2.Close False
        End If
        monFichier = Dir
    Loop

    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

Bonjour à tous,

@Steelson

est ce que filtreArray est spécifique à excel 2013 ?

j'ai un erreur sur cette ligne

result1 = filtreArray(data, critere, cle1)

Error 13 Type incompatible

Le sujet n'était pas facile à comprendre ... je ne sais pas du reste si c'est ce qu'il attendait.

Pour filtrearray, c'est une macro toute faite que j'ai mise dans un autre module

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

Steelson a écrit :

Pour filtrearray, c'est une macro toute faite que j'ai mise dans un autre module

ok, désolé je n'avais pas charger le fichier, c'est fait et je viens de voir la macro filtrearray

Bonjour à tous

Quand je recopie la macro dans mon fichier cela ne fonctionne pas.

Erreur de compilation

Sub ou fonction non définie - result1 = filtreArray(data, critere, cle1)

De plus wb.SaveAs (ThisWorkbook.Path & "\" & cle1 & ".xlsx") je suppose que c'est là que je dois modifier le chemin de sauvegarde

Et si c'est pas trop demandé comment faire afin pour que les formats soient identiques à la base aussi en chiffre que le paramètre de largeur colonnes et couleurs.

Quand à la récupération des données dans la base est il possible de modifier les cellules qui ont été changées par les différents services 671 672 673 674.

Merci de votre aide

Cordialement

rbmicho59 a écrit :

Erreur de compilation

Sub ou fonction non définie - result1 = filtreArray(data, critere, cle1)

Ajoute ceci comme indiqué plus haut ... https://forum.excel-pratique.com/viewtopic.php?p=846426#p846426

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

rbmicho59 a écrit :

De plus wb.SaveAs (ThisWorkbook.Path & "\" & cle1 & ".xlsx") je suppose que c'est là que je dois modifier le chemin de sauvegarde

absolument

rbmicho59 a écrit :

Et si c'est pas trop demandé comment faire afin pour que les formats soient identiques à la base aussi en chiffre que le paramètre de largeur colonnes et couleurs.

ok, je vais regarder ce point

Je recopie juste après l'anomalie ou à la place de

Après la macro, ou dans un autre module, comme dans ce fichier ... https://forum.excel-pratique.com/viewtopic.php?p=846419#p846419

Bonjour

rbmicho59 a écrit :

Et si c'est pas trop demandé comment faire afin pour que les formats soient identiques à la base aussi en chiffre que le paramètre de largeur colonnes et couleurs.

Option Explicit

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$, 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

    For Each cle1 In dico1.Keys
        result1 = filtreArray(data, critere, cle1)
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
        wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
        wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next

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

Exemple ...

rbmicho59 a écrit :

Quand à la récupération des données dans la base est il possible de modifier les cellules qui ont été changées par les différents services 671 672 673 674.

J'ai donc choisi de recompiler dans un autre onglet l'ensemble des données ... tu peux ensuite en faire une comparaison.

Bonjour, de ce fait je remplace la macro qui est dans rbmicho EP-V01.

Merci pour ton aide

... sauf si tu as encore besoin d'un coup de pouce !

Bonjour,

J'ai le message quand j'applique la macro à mon fichier

dico1(data(i, critere)) = ""

Désolé je sais faire des macros toutes simples

Merci

Tu n'as probablement pas les bonnes références cochées

Sinon envoie ton fichier (en mp si nécessaire)

Re,

Voici mon fichier avec la macro avec la laquelle je rencontre également un soucis.

De plus peux tu me donner un exemple pour la sauvegarde exemple sur ma disquette, afin que je puisse modifier par la suite

Merci

La fonction n'était pas mise en place https://forum.excel-pratique.com/viewtopic.php?p=846426#p846426

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

Tes données n'étant pas continues (lignes vierges), tu ne sors que la première ligne !

De plus peux tu me donner un exemple pour la sauvegarde exemple sur ma disquette, afin que je puisse modifier par la suite

Je suis en train de modifier pour partir d'un modèle de mise en page ... si cela t'intéresse, dis le moi.