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
|
Sub Rectangleàcoinsarrondis1_Cliquer()
Dim objOuvrir As FileDialog
Dim objFichiers As FileDialogSelectedItems
Dim wbsource As Workbook, wbdest As Workbook
Set objOuvrir = Application.FileDialog(msoFileDialogOpen)
With objOuvrir 'Affiche la fenêtre "Ouvrir"
.Filters.Clear 'Efface les filtres existants.
.Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm" 'Définit une liste de filtres pour le champ "Type de fichiers".
.Show
Set objFichiers = .SelectedItems 'Définit les fichiers sélectionnés
End With
Worksheets("Armoires").Range("A2:BZ5000").ClearContents
Worksheets("Supports + Foyers").Range("A2:FA5000").ClearContents
If Not objFichiers.Count = 1 Then Exit Sub 'On sort si aucun fichier n'a été sélectionné
Application.ScreenUpdating = False
Set wbdest = ThisWorkbook 'classeur exécutant où sera collée la feuille
Set wbsource = Workbooks.Open(objFichiers(1))
wbsource.Sheets("Armoire").UsedRange.Copy Destination:=wbdest.Sheets("Armoires").Range("A1") '<<<<ADAPTER
wbsource.Sheets("Support + Foyer").UsedRange.Copy Destination:=wbdest.Sheets("Supports + Foyers").Range("A1")
wbsource.Close False
Application.ScreenUpdating = True
Dim pl As Range, sh As Worksheet
For Each sh In Worksheets(Array("Armoires", "Supports + Foyers"))
Set pl = sh.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
If Not pl Is Nothing Then
Cells(Rows.Count, Columns.Count).Copy
pl.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
End If
Next sh
Fin:
End Sub |
Partager