XL 2019 Macro copier /coller une ligne dans un tableau (du menu insertion/tableau)

micsel

XLDnaute Junior
Bonjour,
Cela fait plusieurs heures que j'ai beau essayé de finaliser cette petite macro. (ps je me sers de l'enregistrement de macro, et j'essai d'ajuster)
l'idée est de copier coller des valeurs dans ce tableau en ajout a la ligne a chaque fois.
Voila le petit code :
VB:
Sub rea_destock()
'
' rea_destock Macro
'

'
    Sheets("S").Range("A2:G2").Select
    Selection.Copy
    Sheets("J").Select
    Range("journal[Date]").End(xlDown).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("S").Select
    Range("B4").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("B6").Select
    Selection.ClearContents
    Range("B8").Select
    Selection.ClearContents
    Range("D8:E8").Select
    Selection.ClearContents
End Sub

Merci d'avance pour votre compassion à mon égard :) et de vos réponses.
 
Bonjour Micsel, le forum

Voila ton code reécrit, pas testé sans fichier et tu as une plage nommée (je ne sais pas à quoi elle correspond)
les sélections sont inutiles et ne font que ralentir
pas besoin de passer par copy pour transférer des valeurs
les opérations d'effacement peuvent être faite en multi sélection

Bien cordialement
VB:
Sub rea_destock()
'
' rea_destock Macro
'

'
    Sheets("J").Range("journal[Date]").End(xlDown).Offset(1, 0).Range("A1:G1").Value = Sheets("S").Range("A2:G2").Value
    Sheets("S").Range("B4,B6,B8,D8:E8").ClearContents
End Sub
 

soan

XLDnaute Barbatruc
Inactif
Bonjour micsel, Yeahou,

un essai :

VB:
Sub rea_destock()
  If ActiveSheet.Name <> "S" Then Exit Sub
  Dim cel As Range: Application.ScreenUpdating = 0
  With Worksheets("J")
    Set cel = .Cells(.ListObjects("journal").ListRows.Count + 1, 1)
    [A2:G2].Copy: cel.PasteSpecial -4163: cel.Offset(, 7) = [B4]
    cel.Offset(, 8) = [B6]: cel.Offset(, 9) = [B8]
    [D8:E8].Copy: cel.Offset(, 10).PasteSpecial -4163
  End With
  [B4, B6, B8, D8:E8].ClearContents
  Application.CutCopyMode = 0
End Sub

soan
 

soan

XLDnaute Barbatruc
Inactif
@micsel

sans fichier, c'était pas évident ; voici ton fichier en retour.

* tu es sur la feuille "J", et tu peux voir que la ligne 2 est vide

* va sur la feuille "S", et fais Ctrl e ➯ travail effectué !

VB:
Sub rea_destock()
  If ActiveSheet.Name <> "S" Then Exit Sub
  Application.ScreenUpdating = 0: [A2:G2].Copy
  With Worksheets("J")
    .Cells(.ListObjects("journal").ListRows.Count + 2, 1).PasteSpecial -4163
    [B4, B6, B8, D8:E8].ClearContents: Application.CutCopyMode = 0: .Select
  End With
End Sub

soan
 

Pièces jointes

  • FDV.xlsm
    34.7 KB · Affichages: 9

Discussions similaires