Problème code vba copier des valeurs de plusieurs fichiers à la suite

[jibs]

Bonjour,

Je viens vers vous car j'ai un code qui me permet d'ouvrir un fichier et de copier certaines valeurs de ce fichier dans un autre fichier. Seulement je voudrais réaliser cette action plusieurs fois afin de copier les valeurs de nombreux fichiers qui sont dans un même dossier.
Voilà si jamais quelqu'un peut me donner un coup de main, merci par avance !!!

Code:

Sub ajouter()

Dim TheFile As Variant
Dim WB As Workbook
ThePath = "C:\Users\sc0200115\Desktop\"
UserDir = CurDir
ChDir ThePath

Sheets("Base de donnée").Select
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

TheFile = Application.GetOpenFilename("Excel Files(*.xls),*.xls")

If TheFile = False Then
Exit Sub
End If

Set WB = Workbooks.Open(TheFile)

With WB

With ActiveSheet

Set r1 = .Cells(3, 3)
Set r2 = .Cells(6, 3)
Set r3 = .Cells(12, 6)
Set r4 = .Cells(5, 3)
Set r5 = .Cells(9, 3)
Set r6 = .Cells(9, 4)
Set r7 = .Cells(10, 3)
Set r8 = .Cells(13, 6)
Set r9 = .Cells(14, 6)
Set r10 = .Cells(15, 6)
Set r11 = .Cells(16, 6)
Set r12 = .Cells(17, 6)
Set r13 = .Cells(19, 6)
Set r14 = .Cells(20, 6)
Set r15 = .Cells(24, 3)
Set r16 = .Cells(26, 3).Resize(1, 4)
Set r17 = .Cells(27, 3).Resize(1, 4)
Set r18 = .Cells(28, 3).Resize(1, 4)
Set r19 = .Cells(29, 3).Resize(1, 4)
Set 20 = .Cells(30, 3).Resize(1, 4)
Set 21 = .Cells(30, 8)
Set 22 = .Cells(31, 3).Resize(1, 4)
Set 23 = .Cells(32, 3).Resize(1, 4)
Set 24 = .Cells(32, 9)
Set 25 = .Cells(33, 3).Resize(1, 5)
Set 26= .Cells(36, 2).Resize(1, 4)


End With

End With

Windows("Maquette Outil Excelv1.xlsm").Activate
Sheets("Base de donnée").Select

With ActiveSheet
.Cells(3, 1) = 1
.Cells(3, 2) = r1.Value
.Cells(3, 3) = r2.Value
.Cells(3, 7) = r3.Value
.Cells(3, 4) = r4.Value
.Cells(3, 5) = r5.Value
.Cells(3, 6) = r6.Value
.Cells(3, 8) = r7.Value
.Cells(3, 9) = r8.Value
.Cells(3, 10) = r9.Value
.Cells(3, 11) = r10.Value
.Cells(3, 12) = r11.Value
.Cells(3, 13) = r12.Value
.Cells(3, 14) = r13.Value
.Cells(3, 15) = r14.Value
.Cells(3, 16).Resize(1, 4) = r15.Value
.Cells(3, 20).Resize(1, 4) = r16.Value
.Cells(3, 24).Resize(1, 4) = r17.Value
.Cells(3, 28).Resize(1, 4) = r18.Value
.Cells(3, 32).Resize(1, 4) = r19.Value
.Cells(3, 36) = r20.Value
.Cells(3, 37).Resize(1, 4) = r21.Value
.Cells(3, 41).Resize(1, 4) = r22.Value
.Cells(3, 45) = r23.Value
.Cells(3, 46).Resize(1, 5) = r24.Value
.Cells(3, 51) = r25.Value

For i = 3 To ([nombre_enregistrement] + 1)
.Cells(i + 1, 1) = .Cells(i, 1) + 1
Next

End With

WB.Close

Windows("Maquette Outil Excelv1.xlsm").Activate
Sheets("Base de donnée").Select

End Sub

 

[Pierrot93]

Re : Problème code vba copier des valeurs de plusieurs fichiers à la suite

Bonjour,

regarde peut être du coté de la fonction "Dir", il y a un exemple permettant de boucler dans l'aide vba...

bonne journée
@+