XL 2016 VBA copier/coller

[Yücel]

Bonjour,

J'ai ci-joint un fichier qui fonctionne bien.
C'est à dire lorsque je clique sur le bouton dupliquer, la macro va chercher le numéro indiqué en cellule "C6" dans l'onglet SOURCE et plus exactement dans la colonne A. Puis copier de la colonne
"B à P" toutes les lignes qui contiennent ce numéro et vient le coller dans l’onglet JOURNAL juste en dessous du tableau.

Seulement le soucis est que, si les lignes à copier sont supérieur à 2, il ne me copiera uniquement les 2 première ligne.

Exemple :
le numéro 3 fait quatre lignes, donc lorsque dans l'onglet JOURNAL j'entre le 3 en cellule "C6" puis clique sur le bouton DUPLIQUER, la macro doit me copier les quatre ligne de l'onglet SOURCE pour venir les coller en dessous du tableau.

En vous remerciant d'avance.
Bonne soirée.

 

[job75]

Bonjour Yücel,

Private Sub Dupliquer_Click()
Dim mem
Application.ScreenUpdating = False
Rows("9:" & Rows.Count).Delete 'RAZ
With Sheets("Source")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    mem = .UsedRange.Formula
    .UsedRange = .UsedRange.Value 'supprime les formules
    .[A:A].Replace [C6], "#N/A", xlWhole
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.[A:A].SpecialCells(xlCellTypeConstants, 16).EntireRow, .[B:P]).Copy [B9]
    .UsedRange = mem 'restitue les formules
End With
End Sub

Il n'est pas bon que le tableau dans la feuille "Journal" soit un tableau structuré.

A+

 

[Yücel]

Bonjour et merci Job75

C'est presque ça sauf que les lignes collé ne viennent pas se greffer sur le tableau mais remplace les données déjà existant.

Il faut qu'au fur et à mesure que l'on duplique, le tableau s'agrandit.

Merci encore pour votre aide !

 

[job75]

Private Sub Dupliquer_Click()
Dim mem
Application.ScreenUpdating = False
With Sheets("Source")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    mem = .UsedRange.Formula
    .UsedRange = .UsedRange.Value 'supprime les formules
    .[A:A].Replace [C6], "#N/A", xlWhole
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.[A:A].SpecialCells(xlCellTypeConstants, 16).EntireRow, .[B:P]).Copy Range("B" & UsedRange.Row + UsedRange.Rows.Count)
    .UsedRange = mem 'restitue les formules
End With
End Sub

 

[Yücel]

Un grand merci à vous !

C'est parfait

Très bon weekend et encore merci mille fois.