Public Sub CommandButton1_Click()
Dim w As Workbook, Ouvert As Boolean, Classeur$, Chemin$, NbrChmp&
Dim TabloReport()
Application.ScreenUpdating = False
NbrChmp = 7 '6 Zones à copier dans l'exemple + la date
ReDim TabloReport(1 To NbrChmp)
Classeur = "Destination" & ".xls" 'Nom du classeur de destination
Chemin = ThisWorkbook.Path & "\"
If Dir(Chemin & Classeur) = "" Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & Classeur
End If
For Each w In Workbooks
If w.Name = Classeur Then
Ouvert = True
Exit For
End If
Next w
With ThisWorkbook.Sheets("source")
TabloReport(1) = .Range("A3")
TabloReport(2) = .Range("B3")
TabloReport(3) = .Range("C3")
TabloReport(4) = .Range("D3")
TabloReport(5) = .Range("F3")
TabloReport(6) = .Range("B6")
TabloReport(7) = Now
End With
If Not Ouvert Then Workbooks.Open Filename:=Chemin & Classeur
Windows(Classeur).Activate
Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, NbrChmp) = TabloReport
ActiveWorkbook.Close True
Application.ScreenUpdating = True
rep = MsgBox("Votre base de données est sauvegardée dans : " & Classeur, vbYes + vbInformation, "Copie sauvegarde classeur")
End Sub