Microsoft 365 Copier et coller formes sans changer de feuille

[Chasse]

Bonsoir le Forum

Avec cette macro je dois sélectionner la feuille destinatrice pour pouvoir coller une forme

Sub enregister()
 
  Set ti = Sheets("feuil3")
    
    col = Range("ZZ2").End(xlToLeft).Column
    
    fin = Cells(1000, col).End(xlUp).Row
    Sh = Cells(1, col)
     rt = Sheets(Sh).Range("B100000").End(xlUp).Row + 1
            If Cells(2, col) = 0 Then: Exit Sub
            If rt > 3 Then: Exit Sub
      
            For i = fin To 3 Step -1
                If Cells(i, col) <> "" Then
                    Sheets(Sh).Cells(rt, 2) = Cells(i, 3)
                    Sheets(Sh).Cells(rt, 3) = Cells(i, 4)
                    Sheets(Sh).Cells(rt, 4) = Cells(i, col)
                        ti.Shapes(i - 2).Copy
                            Sheets(Sh).Select
                            Sheets(Sh).Range("A" & rt).Select
                            ActiveSheet.Pictures.Paste
                    ti.Select
                    rt = rt + 1
                End If
            Next
    Sheets(Sh).Range("D1") = "=SUM(D3:D" & rt & ")"
    Sheets(Sh).Range("E1") = "=SUM(E3:E" & rt & ")"
 
If MsgBox("Avez-vous besoin d'une feuille sup.", vbYesNo, "Demande de confirmation") = vbYes Then
        Range(Cells(1, col), Cells(2, col)).Select
            Selection.AutoFill Destination:=Range(Cells(1, col), Cells(2, col + 1)), Type:=xlFillDefault
                    
Worksheets("Model").Copy Before:=Sheets("Model")
    ActiveSheet.Name = "Sachet n° " & (col - 1) / 2
    ActiveSheet.Range("A1") = "Sachet n° " & (col - 1) / 2
End If
  ti.Select
 
End Sub

Est-il possible de le faire directement.

Merci de votre aide et bonne soirée

 

[patricktoulon]

bonsoir j'ai fait le ménage dans ton truc
que dire ....? a part que la conception d indexation dans le nom c'est pas top
j'ai modifié tout ça
ne pas toucher la cellule "C1"elle est automatique

Option Explicit
Sub enregister()
    Dim nomFeuille$, i&, a&, cel As Range
    With Application
        .CopyObjectsWithCells = True
        .ScreenUpdating = False
    End With
    With Sheets("feuil3")
        nomFeuille = .Cells(1, "E")
        For i = 3 To Sheets("Feuil3").UsedRange.Rows.Count - 3
            a = a + 1
            Set cel = Sheets(nomFeuille).Cells(Rows.Count, 2).End(xlUp).Offset(1).Offset(, -1)
            If .Cells(i, "E") <> "" Then .Cells(i, "A").Resize(, 5).Copy cel
        Next
        If a > 0 Then
            Sheets(nomFeuille).Range("D1") = "=SUM(D3:D" & a & ")"
            Sheets(nomFeuille).Range("E1") = "=SUM(E3:E" & a & ")"
            If MsgBox("Avez-vous besoin d'une feuille sup.", vbYesNo, "Demande de confirmation") = vbYes Then
                Worksheets("Model").Copy Before:=Sheets("Model")
                ActiveSheet.Name = "Sachet n° " & .Cells(1, "c") + 1
                ActiveSheet.Range("A1") = "Sachet n° " & .Cells(1, "c") + 1
                .Cells(1, "c") = .Cells(1, "c") + 1
                ThisWorkbook.Save
            End If
        End If
        .Activate
    End With
End Sub

 

[Chasse]

Bonsoir

Merci pour le ménage !

Seulement je ne retrouve plus mes repères et surtout comment l’adapter sur le vrai fichier

J’envoie le fichier original ( il y a 1500 lignes)

Si vous pouvez aussi faire le ménage j’en serait ravi.

Merci infiniment