Importer données de plusieurs classeur dans un seul

Le 04/02/2019 à 21:53

Bonjour Le forum

Je ne sait pas si cela est possible mais:

Je cherche le moyen d'importé a chaque ouverture ou fermeture les donnés de la feuille Synthèse du classeur A

20classeur-a.xlsx (12.19 Ko)

et classeur B

18classeur-b.xlsx (12.22 Ko)

(a la base il y aurais une dizaine de classeur) dans le classeur suivi sur la feuille Synthèse.

19suivi.xlsx (11.41 Ko)

Le but est d'avoir le classeur suivi qui récupère les donnés de tout les classeurs dans un seul et sans doublon .

ce qui évitera d'ouvrir les 10 classeurs.

La macro devra être dans le classeur A et B au vu que c'est la que serons saisie les donné.

Merci de votre aide

Le 05/02/2019 à 00:31

Bonjour,

Modifie cette ligne en fonction du dossier d'enregistrement des fichiers chemin = ThisWorkbook.Path & "\test\"

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim chemin$, monFichier$, derL%, onglet$

Sub collecter()

    ' à modifier ...
    chemin = ThisWorkbook.Path & "\test\"
    onglet = "Synthese"

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

    Do While monFichier <> ""
        wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
        derL = wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Row + 1
        If Not monFichier Like "*.xlsm" Then
            Set wbk2 = Workbooks.Open(chemin & monFichier)
            wbk2.Sheets(onglet).Range("A1").CurrentRegion.Cells.Copy
            wbk1.Sheets(onglet).Paste
            Application.DisplayAlerts = False
                wbk2.Close False
            Application.DisplayAlerts = True
            Rows(derL).Delete Shift:=xlUp
        End If
        monFichier = Dir
    Loop
    wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

j'ai mis le code dans le fichier SUIVI

31suivi.xlsm (21.50 Ko)
Le 05/02/2019 à 01:27

Bonjour,

Bonjour Steelson (-26j),

Une autre proposition.

Identique mais différente.

Les fichiers sont dans le même dossier.

les fichiers à importer sont des xlsx (et le fichier de suivi un xlsm).

Décompresse le zip et ...

Cdlt.

34test.zip (38.54 Ko)
Public Sub ImportData()
Dim wb As Workbook, curWB As Workbook
Dim ws As Worksheet, wsTable As Worksheet
Dim strPath As String, strFilename As String
Dim lo As ListObject
Dim rCell As Range, rng As Range
Const sheetNAME As String = "Synthese"

    Application.ScreenUpdating = False

    Set curWB = ThisWorkbook
    strPath = curWB.Path & Application.PathSeparator
    strFilename = Dir(strPath & "*.xlsx")
    Set wsTable = curWB.Worksheets(sheetNAME)
    Set lo = wsTable.ListObjects(1)

    With lo
        If .InsertRowRange Is Nothing Then
            Set rCell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
        Else
            Set rCell = .InsertRowRange.Cells(1)
        End If
    End With

    Do While strFilename <> ""
        Set wb = Workbooks.Open(strPath & strFilename)
        Set ws = wb.Worksheets(sheetNAME)
        Set rng = ws.Cells(1).CurrentRegion
        rng.Offset(1).Resize(rng.Rows.Count - 1, rng.Columns.Count).Copy
        rCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        wb.Close False
        Set rCell = lo.HeaderRowRange.Cells(1).Offset(lo.ListRows.Count + 1)
        strFilename = Dir
    Loop

End Sub
Le 05/02/2019 à 07:22

Bonjour Jean-Eric

voilà l’instruction que je cherchais !

rng.Offset(1).Resize(rng.Rows.Count - 1, rng.Columns.Count).Copy

c'est plus élégant que de supprimer l'en-tête recopiée à tort !

et pourquoi (26j) ?

Le 05/02/2019 à 08:35

Bonjour Steelson, Jean eric et le forum

Deja merci beaucoup de votre aide.

il y as un probleme sur l'importation car je me retouve avec des doublons.

Le but est de retrouver les même données de la feuille synthese de tout les classeurs dans le fichier suivi feuil synthese MAIS UNE SEUL FOIS.

Comment faire pour pour que l'orsque l'on lance la macro il ne copie pas les lignes deja copier?.

je dit ca comme ca mais n'est t'il pas possible que quand les lignes du classeur A sont copiera la fin de la ligne il y est "OK" (dans la colone AE par exemple)

et qu'il ne transmette dans le fichier SUIVI que les ligne ou il n'y as pas OK

Merci de votre aide.

Le 05/02/2019 à 09:19

Bonjour,

Tu veux dire qu'il y a des lignes ne double dans les différents fichiers ?

Dans ce cas il est facile de les supprimer,

    ActiveSheet.Range("$A$1:$AD$" & der_ligne).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30), Header _
        :=xlYes

mais je voudrais être certain d'avoir bien compris ! Dans les exemples fournis je n'en avais pas trouvé !

Le 05/02/2019 à 09:22

Bonjour,

N'y-t-il pas une clé primaire ou un identifiant unique dans une colonne ?

Cdlt.

Le 05/02/2019 à 10:09

Re bonjour

Aprés plusieurs test cela fonctionne

ENFIN PRESQUE

j'ai enrgistrer la macro a l'ouverture du classeur dans Suivi des Situations global TEST

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim chemin$, monFichier$, derL%, onglet$

    Private Sub Workbook_Open()
ActiveWindow.DisplayWorkbookTabs = True
Sheets("Feuil1").Visible = False

    ' à modifier ...
    chemin = ThisWorkbook.Path & "\suivi\"
    onglet = "Synthese"

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

    Do While monFichier <> ""
        wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
        derL = wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Row + 1
        If Not monFichier Like "*.xlsm" Then
            Set wbk2 = Workbooks.Open(chemin & monFichier)
            wbk2.Sheets(onglet).Range("A1").CurrentRegion.Cells.Copy
            wbk1.Sheets(onglet).Paste
            Application.DisplayAlerts = False
                wbk2.Close False
            Application.DisplayAlerts = True
            Rows(derL).Delete Shift:=xlUp
        End If
        monFichier = Dir
    Loop
    wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select    
    Sheets("MENU").Select
End Sub

et j'ai une erreur de type

erreur

sur la ligne

wbk1.Sheets(onglet).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

je vous joint mes fichier originaux .

Merci de votre aide

15suivi-des-situations-global-test.xlsm (712.34 Ko)
10saisie-par-agents2.xlsm (680.69 Ko)
Le 05/02/2019 à 10:21

Je pense que c'est lié à cela

Sheets("Feuil1").Visible = False

car tu masques la feuille justement appelée Synthese en début de macro

Le 05/02/2019 à 10:32

RE

Je viens de supprimer la ligne et toujours la même erreur.

J'avou je ne comprend pas

Le 05/02/2019 à 12:50

Tu peux supprimer cette ligne car elle n'a pas d'importance sur l'importation.

Mais je doute quand même que tu obtiennes ton résultat ! A voir ...

Rechercher des sujets similaires à "importer donnees classeur seul"