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 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
| Option Explicit
Dim P As String, F As String, S As String, A As String
Dim Arg As String
Dim Dossier As Object, Fichier As Object
Private Function GetValue(Path, File, Sheet, Ref)
If Right(Path, 1) <> "\" Then Path = Path & "\"
If Dir(Path & File) = "" Then
GetValue = "File Not Found"
Exit Function
End If
Arg = "'" & Path & "[" & File & "]" & Sheet & "'!" & Range(Ref).Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(Arg)
End Function
Sub Recuperation()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ThisWorkbook.Sheets("Extraction").Range("B4").CurrentRegion.Offset(1, 0).ClearContents
P = ThisWorkbook.Path 'Chemin du dossier à analyser (à adapter au besoin)
Set Dossier = CreateObject("Scripting.FileSystemObject").getfolder(P) 'Attribue une référence d'objet à la variable
For Each Fichier In Dossier.Files 'Boucle sur les fichier *.xlsx
If Right(Fichier.Name, 9) = "1819.xlsm" Then ' Tri des fichiers Excel
'Transfert des données
With ThisWorkbook.Sheets("Extraction").Range("B1000")
If ThisWorkbook.Name <> Fichier.Name Then
.End(xlUp).Offset(1, 0) = Fichier.Name
F = Fichier.Name: S = "extraction": A = "B2": .End(xlUp).EntireRow.Range("C1").Value = GetValue(P, F, S, A)
A = "c2": .End(xlUp).EntireRow.Range("D1").Value = GetValue(P, F, S, A)
A = "d2": .End(xlUp).EntireRow.Range("E1").Value = GetValue(P, F, S, A)
A = "E2": .End(xlUp).EntireRow.Range("F1").Value = GetValue(P, F, S, A)
A = "f2": .End(xlUp).EntireRow.Range("g1").Value = GetValue(P, F, S, A)
A = "g2": .End(xlUp).EntireRow.Range("h1").Value = GetValue(P, F, S, A)
A = "h2": .End(xlUp).EntireRow.Range("i1").Value = GetValue(P, F, S, A)
A = "i2": .End(xlUp).EntireRow.Range("j1").Value = GetValue(P, F, S, A)
A = "j2": .End(xlUp).EntireRow.Range("k1").Value = GetValue(P, F, S, A)
A = "k2": .End(xlUp).EntireRow.Range("l1").Value = GetValue(P, F, S, A)
A = "l2": .End(xlUp).EntireRow.Range("m1").Value = GetValue(P, F, S, A)
A = "m2": .End(xlUp).EntireRow.Range("n1").Value = GetValue(P, F, S, A)
A = "n2": .End(xlUp).EntireRow.Range("o1").Value = GetValue(P, F, S, A)
A = "o2": .End(xlUp).EntireRow.Range("p1").Value = GetValue(P, F, S, A)
A = "p2": .End(xlUp).EntireRow.Range("q1").Value = GetValue(P, F, S, A)
A = "q2": .End(xlUp).EntireRow.Range("r1").Value = GetValue(P, F, S, A)
A = "r2": .End(xlUp).EntireRow.Range("s1").Value = GetValue(P, F, S, A)
A = "s2": .End(xlUp).EntireRow.Range("t1").Value = GetValue(P, F, S, A)
A = "t2": .End(xlUp).EntireRow.Range("u1").Value = GetValue(P, F, S, A)
A = "U2": .End(xlUp).EntireRow.Range("v1").Value = GetValue(P, F, S, A)
A = "V2": .End(xlUp).EntireRow.Range("w1").Value = GetValue(P, F, S, A)
A = "x2": .End(xlUp).EntireRow.Range("y1").Value = GetValue(P, F, S, A)
A = "y2": .End(xlUp).EntireRow.Range("z1").Value = GetValue(P, F, S, A)
A = "z2": .End(xlUp).EntireRow.Range("aa1").Value = GetValue(P, F, S, A)
A = "aa2": .End(xlUp).EntireRow.Range("ab1").Value = GetValue(P, F, S, A)
A = "ab2": .End(xlUp).EntireRow.Range("ac1").Value = GetValue(P, F, S, A)
A = "ac2": .End(xlUp).EntireRow.Range("ad1").Value = GetValue(P, F, S, A)
A = "ad2": .End(xlUp).EntireRow.Range("ae1").Value = GetValue(P, F, S, A)
End If
End With
End If
Next Fichier
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub |
Partager