Insérer ligne

Salut le forum,

J'ai une macro qui copie une ligne dans une feuille puis la colle dans une autre feuille en insérant cette ligne par le haut (donc doit actuellement déplacer 5000 lignes) ce qui demande beaucoup de temps à chaque création de ligne.

Je souhaiterais modifier cette macro pour insérer ces lignes mais du coup en dessous des autres.

Sub rebut()
'
' rebut Macro
'

'
    ActiveWorkbook.Save
    Sheets("Attention").Select
    ActiveWindow.SmallScroll Down:=-3
    Range("B41:P41").Select
    Selection.Copy
    Sheets("Suivi des rebuts").Select
    ActiveWindow.SmallScroll Down:=-18
    Range("B2:O2").Select
    Selection.Insert Shift:=xlDown
    Range("B2").Select
End Sub

Merci beaucoup

Bonjour,

   ActiveWorkbook.Save
    Set sh1 = Sheets("Attention")
    Set sh2 = Sheets("Suivi des rebuts")
    LastRw = sh2.Cells(Rows.Count, 2).End(xlUp).Row
    sh1.Range("B41:P41").Copy sh2.Range("B" & LastRw + 1).Paste

Salut sabV,

Merci pour ta réponse mais malheureusement cela ne fonctionne pas, voici un screenshot du message d'erreur en pj.

Dis moi si tu as besoin d'autres renseignements.

Merci

Bonjour,

Essaie ainsi :

Public Sub Rebut()
Dim rng As Range, n As Long
    Application.ScreenUpdating = False
    With ActiveWorkbook
        .Save
        Set rng = .Worksheets("Attention").Range("B41:P41")
        With .Worksheets("Suivi des rebuts")
            n = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
            rng.Copy Destination:=.Cells(n, 2)
        End With
    End With
End Sub

Salut Jean Eric,

Merci beaucoup ça fonctionne bien, maintenant j'ai une macro plus complexe à modifier dans le même sens.

Dans le classeur de destination (CD) et l'onglet de destiantion (OD) on vient insérer un nombre de lignes précédemment copiés.

Maintenant je souhiaterais les coller à la suite si c'est possible.

Merci

Voici le code

Option Explicit 'oblige à déclarer toutes les variables

Private Sub UserForm_Initialize() 'à l'initialisation de l'UserForm
'affiche la date du jour
Me.TextBox1.Value = Format(Day(Date), "00") 'jour JJ
Me.TextBox2.Value = Format(Month(Date), "00") 'mois MM
Me.TextBox3.Value = Right(Year(Date), 2) 'années YY
'sélectionne le jour
With Me.TextBox1 'prend en compte la TextBox1
    .SetFocus 'place le curseur
    .SelStart = 0 'début de la sélection
    .SelLength = 2 'longueur de la sélection
End With 'fin de la prise en compte de la TextBox1
End Sub

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'à l'appui sur une touche dans la Textbox1
If KeyAscii > 57 Or KeyAscii < 48 Then KeyAscii = 8 'interdit tout autre caractère que {0, 1, 2, 3, 4, 5, 6, 7, 8 ou 9]
End Sub

Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'à l'appui sur une touche dans la Textbox2
If KeyAscii > 57 Or KeyAscii < 48 Then KeyAscii = 8 'interdit tout autre caractère que {0, 1, 2, 3, 4, 5, 6, 7, 8 ou 9]
End Sub

Private Sub TextBox3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'à l'appui sur une touche dans la Textbox3
If KeyAscii > 57 Or KeyAscii < 48 Then KeyAscii = 8 'interdit tout autre caractère que {0, 1, 2, 3, 4, 5, 6, 7, 8 ou 9]
End Sub

Private Sub CommandButton1_Click() 'bouton "OK"
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim DR As Date 'déclare la variable DR (Date de Référence)
Dim VDR As Long 'déclare la variable VDR (Valeur Date de Référence)
Dim DT As Date 'déclare la variable DT (Date Trouvée)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
On Error Resume Next 'gestion des erreurs, en cas d'erreur passe à la ligne suivante
Set CS = Workbooks("suivi gen4_2017.xlsm") 'définit la classeur source CS
If Err <> 0 Then 'condition : si une erreur a été générée (si le classeur n'est pas ouvert cela génère une erreur)
   MsgBox "Le Classeur [suivi gen4_2017.xlsm] doit être ouvert ! Ouvrez-le et recommencez." 'message
   Exit Sub 'sort de la procédure
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set CD = Workbooks("Prod-Arrêt Ligne GN4-2017.xlsm") 'définit la classeur destination CD
Set OS = CS.Worksheets("Suivi des rebuts") 'définit l'onglet source OS
Set OD = CD.Worksheets("Suivi des rebuts") 'définit l'onglet destination OD
DR = DateSerial(2000 + CInt(Me.TextBox3.Value), CInt(Me.TextBox2.Value), CInt(Me.TextBox1.Value)) 'définit la date de référence DR
VDR = CLng(DR) 'définit la valeur de la date de référence VDR
Unload Me 'vide et ferme l'UserForm1
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
K = 1 'initialise la variable K
For I = 2 To NL 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
   DT = DateSerial(Year(TV(I, 2)), Month(TV(I, 2)), Day(TV(I, 2))) 'définit la date trouvée DT
   If DR = DT Then 'condition : si la date trouvée est la même que la date de référence
       ReDim Preserve TL(1 To NC - 2, 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes - 2, K colonnes)
       For J = 2 To NC - 1 'boucle 2 : sur toutes les colonnes J de TV (en partant de la seconde et sans la dernière)
           TL(J - 1, K) = TV(I, J) 'récupère dans la ligne J - 1 de TL la valeur de la colonne J de TV (=transposition)
           If J = 2 Then TL(J - 1, K) = VDR 'pour la date, récupère la variable VDR
       Next J 'prochaine colonne de la boucle 2
       K = K + 1 'incrémente K (ajoute une colonne à TL)
   End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
If K > 1 Then 'condition : si K est supérieure à 1 (au moins une occurrence trouvée)
   OD.Rows("2:" & K).Insert Shift:=xlDown 'insère K lignes
   OD.Rows("2:" & K).RowHeight = 15 'définit la hquteur des lignes insérées
   'renvoie dans B2 redimensionnée de l'onglet destination le tableau TL transposé
   OD.Range("B2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    OD.Cells(K + 1, 2).Resize(1, 15).Copy 'copy le format de la première ligne avant insertion
   OD.Cells(2, 2).Resize(K + 1, 15).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, _
        skipblanks:=False, Transpose:=False 'colle le format dans les lignes insérées
   Application.CutCopyMode = False 'supprime le clignotement lié à la copie

   CS.Activate
   Columns("M:O").Select 'selectionne les colonnes M à O du suivi rebut gen IV
   Selection.Copy
   Windows("Prod-Arrêt Ligne GN4-2017.xlsm").Activate
   Range("M1").Select
   Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
   'Copie et colle/valeur dans le fichier destination pour mettre à jour les données d'attente validation

End If 'fin de la condition
MsgBox K - 1 & " lignes copiées !" 'message
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
Workbooks("Prod-Arrêt Ligne GN4-2017.xlsm").Activate
Worksheets("Suivi des rebuts").Activate
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=WEEKNUM(RC[1],2)-1"
    Selection.AutoFill Destination:=Range("A2:A25000")
    Range("A2:A125").Select
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "=MONTH(RC[-15])"
    Selection.AutoFill Destination:=Range("Q2:Q25000")
    Range("Q2:Q125").Select
End Sub

RE,

A tester si j'ai compris la chose.

Essaie de mettre tes données sous forme de tableau dans la feuille de calcul OD.

Tu n'auras plus à te préoccuper de la mise en forme des cellules, ou des formules.

Cdlt.

Dim N As Long
    'Restitution des données du tableau TL dans la feuille de calcul OD
    If K > 1 Then
        'Dernière ligne non vide colonne B
        N = OD.Cells(Rows.Count, 2).End(xlUp).Row
        OD.Cells(N + 1, 2).Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    End If

Salut Jean Eric, merci pour cette réponse, en revanche je ne vois pas où placer ton bout de code dans le code existant.

Merci.

Bonjour,

Tu supprimes de ton code :

If K > 1 Then 'condition : si K est supérieure à 1 (au moins une occurrence trouvée)
  OD.Rows("2:" & K).Insert Shift:=xlDown 'insère K lignes
  OD.Rows("2:" & K).RowHeight = 15 'définit la hquteur des lignes insérées
  'renvoie dans B2 redimensionnée de l'onglet destination le tableau TL transposé
  OD.Range("B2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    OD.Cells(K + 1, 2).Resize(1, 15).Copy 'copy le format de la première ligne avant insertion
  OD.Cells(2, 2).Resize(K + 1, 15).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, _
        skipblanks:=False, Transpose:=False 'colle le format dans les lignes insérées
  Application.CutCopyMode = False 'supprime le clignotement lié à la copie

que tu remplaces par le précédent que j'ai envoyé.

En n'oubliant de déclarer la variable N

Salut Jean Eric,

Je viens d'implémenter tes modifs directement en production et tout fonctionne bien.

Merci beaucoup.