Importation par en-tête avec plus d'un fichier

Bonjour à tous,

Je découvre en ce moment le vba et j’ai une requête spécifique dont je n’ai pas trouvé la réponse sur ce forum.

Je souhaite faire une synthèse de plusieurs classeurs (rien d’originale), je souhaite importer des colonnes de 2 ou 3 classeurs distincts (noté source1.xlsx, source2.xlsx, etc…) vers une feuille d’un classeur à part (base.xlsx).

Chaque classeur « source » possède les mêmes colonnes( nommée de la même manière) placés à des endroits différents, il faut donc que les colonnes(de taille variable) soit importé en fonction de leurs en-tête puis mise à la suite.

Je possède ce code qui permet l’importation des colonnes d’un seul fichier en fonction de l’en tête mais je n’arrive pas à l’étendre pour plusieurs et mettre les données des colonnes à la suite.

Je vous joint 3 fichier illustratif.

Je remercie par avance ceux qui prendront le temps de me répondre.

Ps : le code que je possède :

Option Explicit

Sub ImporterColonnes()

Dim Fichier, WbkCopy As Workbook, WbkColle As Workbook

Dim Colonnes(), Col As Integer, Resultat As Variant

'On attribue à la variable WbkColle le fichier actuel (celui qui contient la macro)

Set WbkColle = ThisWorkbook

'A adapter : Nom des entêtes de colonnes à importer

Colonnes = Array("Fournisseur", "Quantité", "Lieu")

'Sélection du fichier

Fichier = Application.GetOpenFilename("Fichiers Excels, *.xls*")

'En cas de clic sur "ANNULER"

If Fichier <> False Then

'On ouvre le fichier en question

Set WbkCopy = Workbooks.Open(Fichier)

With WbkCopy.Sheets("MACHIN") '==> ADAPTER NOM de la feuille

'Boucle sur toutes les entêtes des colonnes

For Col = 1 To .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column

'teste si l'entête correspond à un des noms des colonnes à copier

Resultat = Application.Match(.Cells(1, Col), Colonnes, 0)

'Si l'entête est trouvée (colonne à copier)

If Not IsError(Resultat) Then

'Copié - Collé ==> ADAPTER NOM de la feuille ou coller ("TRUC" à remplacer)

.Columns(Col).Copy WbkColle.Sheets("TRUC").Cells(1, Cells.Columns.Count).End(xlToLeft).Offset(0, 1)

End If

Next Col

End With

WbkCopy.Close

End If

Set WbkCopy = Nothing

Set WbkColle = Nothing

End Sub

Bonjour Smoothly.

Une première idée :

Option Explicit

Sub Importation()
Dim i%, j%
Dim w1 As Workbook, w2 As Workbook
Dim f1 As Worksheet, f2 As Worksheet
Dim rep$, fich$
Dim d As Object: Set d = CreateObject("scripting.dictionary")

'Enregistrement des premières variables.
Set w1 = ThisWorkbook
Set f1 = w1.Sheets("Feuil1")
rep = w1.Path

'On enregistre les en-têtes
With f1
    For i = 1 To 3: d(.Cells(1, i).Value) = i: Next i
End With

'On va boucler les fichiers
fich = Dir(rep & "\" & "*.xlsx")
Do While fich <> w1.Name And Len(fich) > 0
    i = 1
    Set w2 = Workbooks.Open(rep & "\" & fich)
    Set f2 = w2.Sheets("Feuil1")
    j = f1.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
    With f2
        Do While .Cells(1, i).Value <> ""
            If d.exists(.Cells(1, i).Value) Then
                .Range(.Cells(2, i), .Cells(.Cells.Find("*", , , , xlByRows, xlPrevious).Row, i)).Copy f1.Cells(j, d(.Cells(1, i).Value))
            End If
            i = i + 1
        Loop
    End With
    w2.Close False
    fich = Dir()
Loop

End Sub

bravo ! merci beaucoup cela fonctionne très bien.

Cependant, pour certaines colonnes j'ai besoin d'un collage special sinon cela affiche #N/A, que faire ? remplacer .Copy par .CopySpecial ?

merci

Je suppose que tu souhaites copier les valeurs alors :

               
.Range(.Cells(2, i), .Cells(.Cells.Find("*", , , , xlByRows, xlPrevious).Row, i)).Copy
f1.Cells(j, d(.Cells(1, i).Value)).PasteSpecial xlValues
Application.CutCopyMode = False

On vide le presse-papier entre deux pour alléger la boucle.

Au top ! Merci à vous, problème résolu.