Microsoft 365 Copier et coller formes sans changer de feuille

Chasse

XLDnaute Occasionnel
Bonsoir le Forum

Avec cette macro je dois sélectionner la feuille destinatrice pour pouvoir coller une forme
VB:
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
 

Pièces jointes

  • Titanic essai.xlsm
    162.5 KB · Affichages: 4

patricktoulon

XLDnaute Barbatruc
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
VB:
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
 

Pièces jointes

  • Titanic essai.xlsm
    109.5 KB · Affichages: 4

Chasse

XLDnaute Occasionnel
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
 

Pièces jointes

  • Titanic 3.xlsm
    703.9 KB · Affichages: 4

Discussions similaires

Statistiques des forums

Discussions
314 863
Messages
2 113 644
Membres
111 929
dernier inscrit
YJM