Sub extractionValeurCelluleClasseurFerme()
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim Fichier$, Cellule$, Feuille As Worksheet
Dim Plage(), Plage2(), Col()
Plage = Array("F4:H400", "AO4:AP400")
Plage2 = Array("F4:H400", "AW4:AX400")
Col = Array(2, 5)
For i = 1 To Sheets.Count
Sheets(i).Range("B2:F400").ClearContents
Next
Fichier = Dir(ThisWorkbook.path & "\*.xls")
Do While Fichier <> ""
If Fichier <> ThisWorkbook.Name Then
Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.path & "\" & Fichier & ";Extended Properties=""Excel 12.0;HDR=no;"";"
For Each Feuille In ActiveWorkbook.Worksheets
If Left(Feuille.Name, 1) = "F" Or Left(Feuille.Name, 1) = "M" Then
For i = 0 To 1
Cellule = Plage(i)
Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
End With
Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
With Feuille
.Cells(65536, Col(i)).End(3)(2).CopyFromRecordset Rst
End With
Range("A1").Select
Next i
Rst.Close
Else
For i = 0 To 1
Cellule = Plage2(i)
Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
End With
Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
With Feuille
.Cells(65536, Col(i)).End(3)(2).CopyFromRecordset Rst
End With
Next i
Rst.Close
End If
Next
Source.Close
Set Source = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing
End If
Fichier = Dir
Loop
For nb = 1 To Worksheets.Count
Range("A1").Select
Sheets(nb).Sort.SortFields.Clear
Sheets(nb).Sort.SortFields.Add Key:=Range( _
"G2:G400"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With Sheets(nb).Sort
.SetRange Range("A1:G400")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next
Beep
End Sub