Voici un code trouvé sur un autre forum (gcexcel.com) et que j'ai essayé d'adapter à mon besoin
Sub Test()
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
Dim DernLign As Integer 'ligne où on écrit les données
Dim vFichiers As Variant 'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range 'plage où on copie les données
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets("TK") 'on écrit dans la feuille nommée TK du fichier récapitulatif
' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers
' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
Debug.Print "Aucun fichier sélectionné."
MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
On Error Resume Next
Application.ScreenUpdating = False
' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions
Set wbSource = Workbooks.Open(vFichiers(k)) 'on ouvre le fichier
Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1
'DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1 'ligne pour écrire le log des fichiers compilés
' - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0)
'rgRecap = Time
With wsSource
'On recopie des valeurs du fichier B dans un tableau du fichier A, onglet TK
rgRecap.Offset(-45, 3) = .Range("D11")
rgRecap.Offset(-45, 4) = .Range("E11")
rgRecap.Offset(-44, 3) = .Range("D12")
rgRecap.Offset(-44, 4) = .Range("E12")
rgRecap.Offset(-43, 3) = .Range("D13")
rgRecap.Offset(-43, 4) = .Range("E13")
rgRecap.Offset(-42, 3) = .Range("D14")
rgRecap.Offset(-42, 4) = .Range("E14")
rgRecap.Offset(-41, 3) = .Range("D15")
rgRecap.Offset(-41, 4) = .Range("E15")
rgRecap.Offset(-40, 3) = .Range("D16")
rgRecap.Offset(-40, 4) = .Range("E16")
rgRecap.Offset(-39, 3) = .Range("D17")
rgRecap.Offset(-39, 4) = .Range("E17")
rgRecap.Offset(-38, 3) = .Range("D18")
rgRecap.Offset(-38, 4) = .Range("E18")
rgRecap.Offset(-37, 3) = .Range("D19")
rgRecap.Offset(-37, 4) = .Range("E19")
rgRecap.Offset(-36, 3) = .Range("D20")
rgRecap.Offset(-36, 4) = .Range("E20")
rgRecap.Offset(-35, 3) = .Range("D21")
rgRecap.Offset(-35, 4) = .Range("E21")
rgRecap.Offset(-34, 3) = .Range("D22")
rgRecap.Offset(-34, 4) = .Range("E22")
rgRecap.Offset(-33, 3) = .Range("D23")
rgRecap.Offset(-33, 4) = .Range("E23")
rgRecap.Offset(-32, 3) = .Range("D24")
rgRecap.Offset(-32, 4) = .Range("E24")
'rgRecap.Offset(-31, 3) = .Range("D25")
' rgRecap.Offset(-31, 4) = .Range("E25")
rgRecap.Offset(-30, 3) = .Range("D26")
rgRecap.Offset(-30, 4) = .Range("E26")
rgRecap.Offset(-29, 3) = .Range("D27")
rgRecap.Offset(-29, 4) = .Range("E27")
' rgRecap.Offset(-28, 3) = .Range("D28")
' rgRecap.Offset(-28, 4) = .Range("E28")
rgRecap.Offset(-27, 3) = .Range("D29")
rgRecap.Offset(-27, 4) = .Range("E29")
rgRecap.Offset(-26, 3) = .Range("D30")
rgRecap.Offset(-26, 4) = .Range("E30")
rgRecap.Offset(-25, 3) = .Range("D31")
rgRecap.Offset(-25, 4) = .Range("E31")
rgRecap.Offset(-24, 3) = .Range("D32")
rgRecap.Offset(-24, 4) = .Range("E32")
rgRecap.Offset(-23, 3) = .Range("D33")
rgRecap.Offset(-23, 4) = .Range("E33")
rgRecap.Offset(-22, 3) = .Range("D34")
rgRecap.Offset(-21, 4) = .Range("E34")
rgRecap.Offset(-21, 3) = .Range("D35")
rgRecap.Offset(-20, 4) = .Range("E35")
rgRecap.Offset(-20, 3) = .Range("D36")
rgRecap.Offset(-19, 4) = .Range("E36")
rgRecap.Offset(-18, 3) = .Range("D37")
rgRecap.Offset(-18, 4) = .Range("E37")
rgRecap.Offset(-17, 3) = .Range("D38")
rgRecap.Offset(-17, 4) = .Range("E38")
'rgRecap.Offset(-16, 3) = .Range("D39")
'rgRecap.Offset(-15, 4) = .Range("E39")
rgRecap.Offset(-15, 3) = .Range("D40")
rgRecap.Offset(-14, 4) = .Range("E40")
rgRecap.Offset(-14, 3) = .Range("D41")
rgRecap.Offset(-13, 4) = .Range("E41")
rgRecap.Offset(-12, 3) = .Range("D42")
rgRecap.Offset(-12, 4) = .Range("E42")
' rgRecap.Offset(-11, 3) = .Range("D43")
' rgRecap.Offset(-11, 4) = .Range("E43")
End With
wbSource.Close 'fermer fichier
Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k
Application.ScreenUpdating = True
Application.StatusBar = False
Worksheets("TK layer costs").Activate
End Sub
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
Questions ; n'y a t il pas un moyen plus court pour faire la recopie des données et éviter toutes ces lignes RgRecap.Offset ?
Le point de départ de la recopie se fait par un incrément négatif à partir du bas du tableau (via la fonction
) si j'ai bien compris.
Existe t il une formule pour le faire dans l'autre sens, c'est à dire avec un incrément positif en partant de la cellule A;1
