Copie rune feuille a la fin d un autre classeur
Bonsoir,
j'ai beau chercher, je trouve juste comment copier une feuille en derniere position dans un meme classeur...(en utilisant sheet.count...)
Ce que j'aimerai c'est un code vba qui me permette de coller ma feuille en derniere position d'un autre classeur...j'ai essayé d'adapter le code mais cela m'échappe...
Tout le code est bon c'est juste l'emplacement de copie qui n'est pas bon
Merci a vous
cordialement
voici le code que j'ai écrit:
Sub COPICR()
'
' COPICR Macro
'
'
Application.ScreenUpdating = False
Dim a As Byte
Dim wb As Workbook
Set wb = Workbooks.Open("C:\Users\Jean Charles\Desktop\CR2018.xlsx")
Windows("CHENIL PROJET.xlsm").Activate
Workbooks("CHENIL PROJET.xlsm").Sheets("CR").Copy After:=Workbooks("CR2018.xlsx").Sheets(xlLast)
Range("B17:AT66").Select
Selection.Copy
Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("Bevel 2")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Bevel 3")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.Delete
ActiveSheet.Name = "Sem " & Range("A3")
Range("B17").Select
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Range("A1").Select
End Sub
Bonjour,
à tester,
Set wb1 = Workbooks("CHENIL PROJET.xlsm)
Set wb2 = Workbooks.Open("C:\Users\Jean Charles\Desktop\CR2018.xlsx")
wb2.Sheets("CR").Copy After:=wb1.Sheets(wb1.Sheets.Count)merci de ta réponse,
voici ce qu'excel me répond:
erreur d'execution 9
l'indice n'appartient pas a la sélection
la ligne posant probleme est surlignée
le code est le suivant:
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb1 = Workbooks("CHENIL PROJET.xlsm")
Set wb2 = Workbooks.Open("C:\Users\Jean Charles\Desktop\CR2018.xlsx")
Windows("CHENIL PROJET.xlsm").Activate
wb2.Sheets("CR").Copy After:=wb1.Sheets(wb1.Sheets.Count)
Range("B17:AT66").Select
Selection.Copy
Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("Bevel 2")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Bevel 3")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.Delete
ActiveSheet.Name = "Sem " & Range("A3")
Range("B17").Select
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Range("A1").Select
End Sub
C'est bon j ai résolu le probléme, ta piste était bonne sabV
dans le code que tu m'as écrit tu avais inversé wb1 et wb2 sur la ligne de copie...
cela donne ca au final:
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb1 = Workbooks("CHENIL PROJET.xlsm")
Set wb2 = Workbooks.Open("C:\Users\Jean Charles\Desktop\CR2018.xlsx")
Windows("CHENIL PROJET.xlsm").Activate
wb1.Sheets("CR").Copy After:=wb2.Sheets(wb2.Sheets.Count)
Range("B17:AT66").Select
Selection.Copy
Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("Bevel 2")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Bevel 3")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.Delete
ActiveSheet.Name = "Sem " & Range("A3")
Range("B17").Select
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Range("A1").Select
End Sub
Merci pour tout
Bonne soirée