Exportation de données de plusieurs classeurs vers un autre

Le 24/04/2017 à 18:44

Sujet: Exportation de données de plusieurs classeurs vers un autre classeur

Bonjour

Je souhaiterai créer une macro qui recupere les données de 4 classeurs excels en fonction de la période préablement choisis:

  • ptf_vl
  • ptf_inv
  • niv_ind
  • bmk
pour ensuite coller les données dans le classeur "principal " et dans la feuille excel adequate ( feuilee excel ont le meme nom que le classeur d'origine)

Exemple:

L'utilisateur choisit la plage du 01/04/2017 au 18/04/2017 alors la macro va aller dans les 4 fichiers excel et recuperer les information qui se trouve dans cette periode pour chaque classeur et le coller dans le classeur nommé " principal".

Voici une tentative de code(le pb c'est qu'il ne recupere qu'il ne recupere qu'une seul donnée et/ou refuse d'ouvrir le dossier)

   Sub transfert()

    Dim Last_niv As Long, Last_bmk As Long, Last_vl As Long, Last_inv As Long
    Dim NIV As Workbook, BMK As Workbook, VL As Workbook, INV As Workbook
    Dim ws_niv As Worksheet, ws_bmk As Worksheet, ws_vl As Worksheet, ws_inv As Worksheet
       Dim der_niv As Integer, der_bmk As Integer, der_vl As Integer, der_inv As Integer
       Dim cell As Range

    Dim debut As Date
    Dim fin As Date
debut = InputBox("debut")
fin = InputBox("fin")

'reperetoire principal
    Set WB1 = ThisWorkbook
    Set wsbmk = WB1.Sheets("bmk")
    Set wsniv = WB1.Sheets("niv_ind")
    Set wsvl = WB1.Sheets("ptf_vl")
    Set wsinv = WB1.Sheets("ptf_inv")

    'La ou on va recuperer les donnees

    Set BMK = Workbooks.Open("U:\PROJET\statpro\bmk.xlsx")
    Set ws_bmk = BMK.Sheets("Feuil1")

    Set NIV = Workbooks.Open("U:\PROJET\statpro\bmk.xlsx")
    Set ws_vl = NIV.Sheets("check_IND_NIV_SPA")

    Set INV = Workbooks.Open("S:\PRD\Statpro\Out\Archives\Controle_PTF_170424084456.zip\check_PTF_INV_SPA.csv")
    Set ws_inv = INV.Sheets("check_PTF_INV_SPA")

    Set VL = Workbooks.Open("S:\oleil\finances\PRD\Statpro\Out\Archives\Controle_PTF_170424084456.zip\check_PTF_VL_SPA.csv")
    Set ws_vl = INV.Sheets("check_PTF_VL_SPA")

'dernieres lignes des fichiers statpro
    Last_niv = ws_niv.Range("A" & Rows.Count).End(xlUp).Row
    Last_bmk = ws_bmk.Range("A" & Rows.Count).End(xlUp).Row
    Last_vl = ws_vl.Range("A" & Rows.Count).End(xlUp).Row
    Last_inv = ws_inv.Range("A" & Rows.Count).End(xlUp).Row

'dernieres lignes du fichier principal
    der_niv = wsniv.Range("A" & Rows.Count).End(xlUp).Row
    der_bmk = wsbmk.Range("A" & Rows.Count).End(xlUp).Row
      der_vl = ws_l.Range("A" & Rows.Count).End(xlUp).Row
    der_inv = wsinv.Range("A" & Rows.Count).End(xlUp).Row

'Transfert de données
'selection bmk
For Each cell In ws_bmk.Range("D3:D65000")
If cell > debut And cell < fin Then
For j = 1 To 4
wsbmk.Cells(der_bmk + 1, j) = ws_bmk.Cells(cell.Row, j).Value
Next j
End If
Next cell

    End Sub
21bmk.xlsx (12.99 Ko)
12niv-ind.xlsx (10.73 Ko)
25principal.xlsm (27.12 Ko)
16ptf-inv.xlsx (12.01 Ko)
13ptf-vl.xlsx (11.49 Ko)
Le 25/04/2017 à 08:45

Bonjour,

dans votre macro il y a,

    Set BMK = Workbooks.Open("U:\PROJET\statpro\bmk.xlsx")
    Set NIV = Workbooks.Open("U:\PROJET\statpro\bmk.xlsx")
    Set INV = Workbooks.Open("S:\PRD\Statpro\Out\Archives\Controle_PTF_170424084456.zip\check_PTF_INV_SPA.csv")

2 variables différente (BMK et NIV) qui se réfère au même fichier

aussi vous pourriez lire les fichiers sans les ouvrir et récupérer toutes les données sur une feuille temporaire,

et à partir de cette feuille temporaire réaliser le filtre "période"

par exemple,

'Nécessite d'activer la référence Microsoft ActiveX Data Objects x.x Library
Function LireCellule(repertoire As String, fichier As String, feuille As String)
  Set cnn = New ADODB.Connection

'--- Connexion ---
With cnn
        .Provider = "Microsoft.Jet.OLEDB.12.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
           & repertoire & "\" & fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"""
       .Open
 End With

'--- récupérer les données --
 Set rs = cnn.Execute("SELECT * FROM [" & feuille & "$" & cellule & "]")
  Cells(1, 1).CopyFromRecordset rs

  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Function
Le 25/04/2017 à 09:14

Bonjour

Oui effectivement je n'ai pas corrigé ce detail , voici le correct dossier:

[/  Sub transfert()

    'La ou on va recuperer les donnees

    Set BMK = Workbooks.Open("U:\PROJET\statpro\bmk.xlsx")
    Set ws_bmk = BMK.Sheets("Feuil1")

     SET NIV = Workbooks.Open("U:\PROJET\statpro\ind_niv.xlsx")
    Set ws_vl = NIV.Sheets("Feuil1")

    Set INV = Workbooks.Open("U:\PROJET\statpro\ptf_inv.xlsx")
    Set ws_inv = INV.Sheets("Feuil1")

    Set VL = Workbooks.Open("U:\PROJET\statpro\ptf_vl.xlsx")
    Set ws_vl = VL.Sheets("Feuil1")

  code]

Donc ta solution serait de copier le premier classeur sur un feuille dite TEMP du Excel de destination(le fichier Principal) et ensuite appliquer les filtres pour les copier/coller sur la bonne feuille et faire ainsi pour les 3 autres fichiers Excel ?
Es que ta solution serait aussi valable pour des fichiers excel csv ?

Dans ton code je comprend pas tres bien cette partie:
[code]'--- récupérer les données --
 Set rs = cnn.Execute("SELECT * FROM [" & feuille & "$" & cellule & "]")
  Cells(1, 1).CopyFromRecordset rs

  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Function

Il copie les donnees d'un fichiers excel "source" vers le fichier de destination c'est ca ? Pourquoi selectionne t-il qu'une cellule au lieu d'une plage ?

Merci beaucoup pour ton aide

Le 25/04/2017 à 09:27
Cells(1, 1).CopyFromRecordset rs

Cells(1, 1) est la cellule de destination du Recordset (rs)

la requete est

Set rs = cnn.Execute("SELECT * FROM [" & feuille & "$" & cellule & "]")

cellule: étant toute les cellules de la variable feuille

p/s ce sont 2 lignes différentes

curieusement excel comprend la variable "cellule" sans que nous eussions à la définir.

Le 25/04/2017 à 11:49

Ok et cette instruction est à adapter pour les 4 fichiers sources, c'est ca ?

Le 25/04/2017 à 14:16

Bonjour voilà une proposition.

il faut que ton fichier "Principal" soit dans le même dossier que tes 4 fichiers sources.

Et que le noms de ces fichiers correspondent au nom des feuilles du fichier "Principal".

Et que que ce soit la première feuille de tes fichiers sources qui contiennent les données.

J'ai fait un test avec 4 fichiers nommés 1, 2, 3 et 4 plus mon fichier principal contenant des feuilles du même nom, cela fonctionne.

Sub ListingFichiers2()
Application.DisplayAlerts = False
Dim Rep As String, Fichier As String
Dim ws As Worksheet, wk As Worksheet

debut = CDate(InputBox("Debut ?"))
fin = CDate(InputBox("Fin ?"))

Rep = Workbooks(ActiveWorkbook.Name).Path & "\"
Fichier = Dir(Rep)
NomFic = Left(Fichier, Len(Fichier) - 5)
Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        Workbooks(Fichier).Activate
        On Error GoTo 0
        End If
            Set ws = ActiveWorkbook.ActiveSheet
            Derws = ws.Range("A" & Rows.Count).End(xlUp).Row
                For Each wk In Workbooks("Analyse 2017.xlsm").Sheets
                Derwk = wk.Range("A" & Rows.Count).End(xlUp).Row
                    If NomFic = wk.Name Then
                        For Each cel In ws.Range("G3:G" & Derws)
                        c = CDate(cel.Value)
                            If i <> 1 And IsDate(debut) Then
                                If c >= debut Then
                                    x = cel.Row
                                    i = 1
                                End If
                            Else
                                If cel.Row <> Derws Then
                                    If c > fin Then
                                        y = cel.Row - 1
                                        Exit For
                                    End If
                                Else
                                    y = Derws
                                End If
                            End If
                        Next cel
                        MsgBox x & Chr(13) & y
                        ws.Range("A" & x & ":N" & y).Copy
                        wk.Range("A" & Derwk + 1).PasteSpecial
                        Else
                    End If
                Next wk
        Application.DisplayAlerts = False
        Workbooks(Fichier).Close False
        Application.DisplayAlerts = True
        Fichier = Dir
        Else
        Fichier = Dir
    End If
Loop

End Sub

A plus

Le 25/04/2017 à 14:24

Hello

@Braters ça marche super. Sauf que dans mon cas le fichier "principal" ne peux pas etre avec les fichiers sources et les 4 fichiers sources ne sont pas dans les meme dossiers ( 2 excel dans le meme dossier et les deux autres dans un autre )

aurai-tu une solution à ce probleme ?

Le 25/04/2017 à 14:53

Bonjour,

La solution serait de mettre dans ton fichier "Principal" les liens de tes fichiers comme une liste.$

Par exemple : "C:\Users\Desktop\Test\bmk.xlsx"

Ainsi de suite puis tu sélectionnes cette liste et tu lui attribues un nom ("Lien" dans ma macro). La macro va parcourir les liens pour ouvrir les fichiers et donc pas de soucis d'emplacement logiquement !

Sub ListingFichiers2()
Application.DisplayAlerts = False
Dim Rep As String
Dim ws As Worksheet, wk As Worksheet

debut = CDate(InputBox("Debut ?"))
fin = CDate(InputBox("Fin ?"))

For Each Fichier In Range("Lien")
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        Workbooks(Fichier).Activate
        On Error GoTo 0
        End If
            Set ws = ActiveWorkbook.ActiveSheet
            NomFic = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
            Derws = ws.Range("A" & Rows.Count).End(xlUp).Row
                For Each wk In Workbooks("Analyse 2017.xlsm").Sheets
                Derwk = wk.Range("A" & Rows.Count).End(xlUp).Row
                    If NomFic = wk.Name Then
                        For Each cel In ws.Range("G3:G" & Derws)
                        c = CDate(cel.Value)
                            If i <> 1 And IsDate(debut) Then
                                If c >= debut Then
                                    x = cel.Row
                                    i = 1
                                End If
                            Else
                                If cel.Row <> Derws Then
                                    If c > fin Then
                                        y = cel.Row - 1
                                        Exit For
                                    End If
                                Else
                                    y = Derws
                                End If
                            End If
                        Next cel
                        MsgBox x & Chr(13) & y
                        ws.Range("A" & x & ":N" & y).Copy
                        wk.Range("A" & Derwk + 1).PasteSpecial
                        Else
                    End If
                Next wk

        Application.DisplayAlerts = False
        Workbooks(NomFic & ".xlsx").Close False
        Application.DisplayAlerts = True
    End If
Next Fichier

End Sub
Le 25/04/2017 à 15:50

@BRATERS j'ai pas trop compris ce que tu veux dire par l'ajout des liens..

J'ai ajouté mon fichier " principal", es ce que tu voulais dire ?

19principal.xlsm (25.58 Ko)
Le 25/04/2017 à 16:01

C'est ca, maintenant tu sélectionnes les 4 cellules, tu cliques droit, "Définir un nom...", tu nommes la liste "Lien".

Si tu as bien collé la derniere version de la macro que je t'ai envoyé cela devrait fonctionner.

A plus

EDIT : Je n'avais pas vu que tes fichiers étaient en .csv

Il y aura surement une ou deux lignes à changer.

Le 25/04/2017 à 16:27

@braters Es que tu peux me mettre tes 4 fichiers à toi que je puisse m'en inspirer pour adapter à mon cas.

Car ca marche pas pour moi...

Le 25/04/2017 à 16:42

@braters ou es que tu peux mettre des commentaire dans ton code ?

Moi je recois le message d'erreur "les zones copier/coller sont de forme différentes"

@braters : peux tu détailler cette partie de ton code stp

MsgBox x & Chr(13) & y
                        ws.Range("A" & x & ":N" & y).Copy
                        wk.Range("A" & Derwk + 1).PasteSpecial

Pour rappel je souhaite juste récuperer les lignes dont la date(colonne G) se trouve entre le début et la fin fixé via les inputbox.

Merci d'avance

J'attend ta réponse

Le 25/04/2017 à 17:49

Mon soucis est de savoir si tes fichiers sources sont en .csv ou en .xlsx, car ceux que tu as joint sont en .xlsx et les liens que tu as mis dans ton fichier finissent par .csv !

Si les fichiers sont en .csv,peux tu m'en envoyer un stp

A plus

Le 25/04/2017 à 18:01

@braters Les fichiers test que j'ai choisis sont en xlsx. Mais les " Vrai" fichiers sont en csv.

J'ai testé ton prog sur les fichiers en xlsx et il bloque. Le message d'erreur est " Zone copie/coller sont de forme differente"

A quoi c'est du ?

Le 25/04/2017 à 21:01

Bonjour,

voici l'exemple avec la Function LireCellule(repertoire As String, fichier As String, feuille As String, dest As String)

16slimshady-principal.xlsm (28.84 Ko)
Le 26/04/2017 à 16:34

@sebV J'ai adapté ton prog et voici le message d'erreur qui ressort... Peux tu m'aider ?

capture
Le 26/04/2017 à 16:51

Bonjour, je te mets en lien les fichiers que j'ai utilisé, je te laisse adapter les chemins d'accès.

Je t'ai mis que les 2 premiers liens les autres fichiers étant vide.

A plus !

23analyse-2017.xlsm (33.15 Ko)
111.xlsx (10.10 Ko)
172.xlsx (8.67 Ko)
Rechercher des sujets similaires à "exportation donnees classeurs"