Microsoft 365 Copier et coller formes sans changer de feuille

Chasse · 29 Octobre 2022

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

patricktoulon · 29 Octobre 2022

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

Chasse · 29 Octobre 2022

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

Microsoft 365 Copier et coller formes sans changer de feuille

Chasse

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Chasse

XLDnaute Occasionnel

Pièces jointes

Discussions similaires

Microsoft 365 Copier et coller formes sans changer de feuille

Chasse

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Chasse

XLDnaute Occasionnel

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency