'################################################################
'### Nécessite une référence à Library ADODB ###
'### C:\Program Files\Fichiers communs\System\ado\msado15.dll ###
### Microsoft ActiveX Data Objects 2.x Library ###
'################################################################
Sub test_pmo()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim S As Worksheet
Dim S2 As Worksheet
Dim fichier_outil As String
Dim essai As String
Dim dossier_base As String
Dim dossier_essai As String
Dim fichier_foot As String
Dim i&
Dim temps
Dim oConn As ADODB.Connection
Dim oCmd As ADODB.Command
Dim oRS As ADODB.Recordset
temps = Timer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB1 = ThisWorkbook
'recupération du nom du fichier courant
fichier_outil = WB1.Name
'Pour plus de clarté je vais noté mon chemin de base de mon dossier
essai = "essai du " & Format(Now, "dd-mm-yyyy") & " à " & Format(Time$, "hh.mm.ss")
dossier_base = WB1.Path & "\"
dossier_essai = dossier_base & essai & "\"
'CREATION DU DOSSIER ESSAI
If Len(Dir(dossier_essai, vbDirectory)) = 0 Then MkDir dossier_essai
Set S = WB1.Sheets("football")
S.Copy after:=Sheets(S.Index)
Set S2 = ActiveSheet
With S2.Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
S2.[a1].Select
Application.CutCopyMode = False
' Creation du nouveau fichier
fichier_foot = "2_foot.xls"
Set WB2 = Workbooks.Add(xlWBATWorksheet)
'--- On ne copie l'onglet qu'une seule fois ---
S2.Copy after:=WB2.Sheets(1)
With WB2
.Sheets(1).Delete
.Sheets(1).Name = S.Name
.SaveAs dossier_essai & fichier_foot
.Close
End With
Set WB2 = Nothing
S2.Delete
Set S2 = Nothing
'--- On duplique, à l'identique, le fichier 18 fois (seule l'incrémentation du nom change) ---
For i = 3 To 20
FileCopy dossier_essai & fichier_foot, dossier_essai & i & "_foot.xls"
Next i
'--- On utilise ADO pour accéder à chaque classeur fermé et y changer la valeur en C1 ---
For i = 2 To 20
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dossier_essai & i & "_foot.xls" & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;"";"
Set oCmd = New ADODB.Command
With oCmd
.ActiveConnection = oConn
.CommandText = "SELECT * from " & Chr(96) & S.Name & "$" & "c1:c1" & Chr(96)
End With
Set oRS = New ADODB.Recordset
With oRS
.Open oCmd, , adOpenKeyset, adLockOptimistic
oRS(0).Value = i
.Update
End With
oConn.Close
Set oConn = Nothing
Set oCmd = Nothing
Set oRS = Nothing
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox Timer - temps & " secondes"
End Sub
