copier coller

[amandine]

bonsoir à tous

je me suis lancé à faire une macro pour archiver les donnees B3.B17
mais la macro se plante une fois sur 2

merci a tous et bonne soirée

amandine

Dim Ligne As Integer
Application.ScreenUpdating = False

Sheets('SAISIE').Select
Range('B3:B17').Select
Selection.Copy
Sheets('ARCHIVE').Select
ActiveSheet.Unprotect



Ligne = ActiveSheet.Range('A65536').End(xlUp).Row + 1
Worksheets('archive').Range('A' & Ligne).Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Sheets('ARCHIVE').Select
Range('a1').Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets('SAISIE').Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.CutCopyMode = False
Range('B3').Select
End Sub [file name=Archiver.zip size=9030]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Archiver.zip[/file]

 

[Charly2]

Bonjour Amandine, bonjour à toutes et à tous

Enfin ! Ça marche !!!

Essaie donc ceci:

Sub Macro_archiver()
'
Dim Ligne As Integer
'
  Application.ScreenUpdating = False
  
  ActiveSheet.Unprotect
  
  With Sheets('archive')
    .Unprotect
    Ligne = .Range('A65536').End(xlUp).Row + 1
    Range('B3:B17').Copy
    .Range('A' & Ligne).PasteSpecial Paste:=xlValues, _
                  Transpose:=True
    .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
  End With
  
  ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
  
  Range('B3').Select
  
  Application.ScreenUpdating = True
End Sub[url]

S'il y a des &nb sp; à traîner, tu les supprime ;)

A+

 

[amandine]

merci beaucoup Charly
et bon weekend