XL 2016 VBA copier ligne dans un tableau

Yücel

XLDnaute Junior
Bonjour,

Lorsque j'entre un numéro dans la cellule "C6" de l'onglet "Journal"et que je clique sur le bouton "Dupliquer", il doit aller sur l'onglet "Dupliquer" et copier
(de la colonne B à P) toutes les lignes (avec ce même numéro indiqué en "colonne A") puis me les coller en dessous du tableau en m'insérant des lignes.

Est-ce possible ?? merci pour votre aide !

Ci-joint le fichier.

Avec mes remerciements.

Bonne soirée.
 

Pièces jointes

  • Tuto 2.xlsm
    467.3 KB · Affichages: 25
Solution
Deuxième essai
VB:
Sub Dupliquer()
Dim ZoneToFilter As Range
With ActiveSheet
    Pièce = .Range("C6")
    FinJ = .Range("B" & .Rows.Count).End(xlUp).Row + 2
End With

With Sheets("Dupliquer")
    FinDup = .Range("A" & .Rows.Count).End(xlUp).Row
    Set ZoneToFilter = .Range("A1:P" & FinDup)
    ZoneToFilter.AutoFilter
    ZoneToFilter.AutoFilter Field:=1, Criteria1:=CStr(Pièce)
    'NbLignesFiltrée = ZoneToFilter.Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1
    ZoneToFilter.Offset(1, 1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Journal").Range("B" & FinJ)
    
    
'    Set zone = .Range("A1:A" & FinDup).Find(Pièce)
'        If Not zone Is Nothing Then
'            FirstAd = zone.Address
'            Do
'...

vgendron

XLDnaute Barbatruc
Hello
un essai avec ce code
VB:
Sub Dupliquer()

With Sheets("Dupliquer")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row + 2
End With

With ActiveSheet
    Pièce = .Range("C6")
    With Range("Tableau1")
        Set zone = .Columns(2).Find(Pièce)
        If Not zone Is Nothing Then
            Set ZoneToDupliq = zone.Offset(0, -1).Resize(2, 15)
            ZoneToDupliq.Copy Destination:=Sheets("Dupliquer").Range("B" & fin)
            Sheets("Dupliquer").Range("A" & fin).Resize(2) = Pièce
        End If
    End With
End With


End Sub
 

vgendron

XLDnaute Barbatruc
Deuxième essai
VB:
Sub Dupliquer()
Dim ZoneToFilter As Range
With ActiveSheet
    Pièce = .Range("C6")
    FinJ = .Range("B" & .Rows.Count).End(xlUp).Row + 2
End With

With Sheets("Dupliquer")
    FinDup = .Range("A" & .Rows.Count).End(xlUp).Row
    Set ZoneToFilter = .Range("A1:P" & FinDup)
    ZoneToFilter.AutoFilter
    ZoneToFilter.AutoFilter Field:=1, Criteria1:=CStr(Pièce)
    'NbLignesFiltrée = ZoneToFilter.Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1
    ZoneToFilter.Offset(1, 1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Journal").Range("B" & FinJ)
    
    
'    Set zone = .Range("A1:A" & FinDup).Find(Pièce)
'        If Not zone Is Nothing Then
'            FirstAd = zone.Address
'            Do
'            Set ZoneToDupliq = zone.Offset(0, 1).Resize(2, 15)
'            ZoneToDupliq.Copy Destination:=Sheets("Journal").Range("B" & finJ)
'            finJ = finJ + 2
'
'            Loop While Not zone Is Nothing And zone.Address <> FirstAd
'        End If
ZoneToFilter.AutoFilter
End With


End Sub

par contre;. il ya quand meme un pb avec ton fichier
parfois il y a des listes de validations, parfois non
dans ton tableau, il y a des formules. ou pas.. et quand il y en a une.. elle n'est pas sur toute la colonne...du coup.. ca fout le boxon..
 

Yücel

XLDnaute Junior
Bonjour Vgendron,

En récupérant une partie de votre code ci-dessous, c'est exactement ça sauf qu'il ne s'ajoute pas au tableau mais à la feuille en laissant une ligne de vide...

VB:
Private Sub Dupliquer_Click()

Dim ZoneToFilter As Range
With ActiveSheet
    Pièce = .Range("C6")
    finJ = .Range("B" & .Rows.Count).End(xlUp).Offset(1).Select
End With

With Sheets("Source")
    FinDup = .Range("A" & .Rows.Count).End(xlUp).Row
    Set zone = .Range("A1:A" & FinDup).Find(Pièce)
        If Not zone Is Nothing Then
            FirstAd = zone.Address
            Do
            Set ZoneToDupliq = zone.Offset(0, 1).Resize(2, 15)
            ZoneToDupliq.Copy Destination:=Sheets("Journal").Range("B" & finJ)
            finJ = finJ + 2

            Loop While Not zone Is Nothing And zone.Address <> FirstAd
        End If

End With

End Sub

Merci pour votre aide.
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Au plus court :
VB:
Private Sub Dupliquer_Click()
   With Me.ListObjects(1)
      .ListRows.Add
      .ListRows.Add.Range.Offset(-1).Resize(2).Value _
         = Feuil6.[B2:P3].Offset(3 * Me.[C6].Value).Value
      End With
   End Sub
Mais attention, les modèles copié ne sont pas cohérents avec les lignes déjà en place, de sortes que les MFC réagissent mal.
 

Dranreb

XLDnaute Barbatruc
Vous pouvez ajouter certaines formules :
Code:
Private Sub Dupliquer_Click()
   Dim Rng As Range
   With Me.ListObjects(1)
      .ListRows.Add
      Set Rng = .ListRows.Add.Range.Offset(-1).Resize(2)
      End With
   Rng.Value = Feuil6.[B2:P3].Offset(3 * Me.[C6].Value).Value
   Rng(2, 1).FormulaR1C1 = "=R[-1]C"
   Rng(1, 2).FormulaR1C1 = "=R[-1]C+1"
   Rng(2, 2).FormulaR1C1 = "=R[-1]C"
   End Sub
 

Yücel

XLDnaute Junior
Bonjour Dranreb !

Merci bcp !! on se rapproche bcp sauf quelques petit anomalie. Tu trouveras ci-joint mon fichier avec les annotations.

Très bonne journée à vous.
 

Pièces jointes

  • Tuto 3 presque BON ! - Copie.xlsm
    910 KB · Affichages: 6

Dranreb

XLDnaute Barbatruc
Ah oui mais c'est vous qui avez mis des formules depuis, dans vos modèles. Il n'y en avait pas au départ. Alors soit vous essayez avec un pastespecial en formula, soit vous les mettez de toute pièce.
L'important c'est la façon d'ajouter les lignes.
 

Yücel

XLDnaute Junior
Finalement dur dur !!! j'ai compris style de formule R1C1 mais les formule à copier sont plus complexe :(

N'y a t-il pas un moyen de traduire en macro "récupérer les formules des cellules..." au lieu de les retaper en R1C1 ??

Ci-joint le fichier. merci à vous.
 

Pièces jointes

  • Tuto 3 presque BON ! - Copie.xlsm
    898 KB · Affichages: 11

Discussions similaires

Réponses
12
Affichages
217