Copier Coller certaine Feuilles avec Condition

Bonjour,

j'ai une feuille synthèse pour une récap avec un bouton "Synthèse". j'ai fait une macro mais celle ci elle longue. je souhaiterais l'accélérer.

- Passer que dans certaine feuilles (COMMUN, PVC - Débit, PVC - Assem. ferrures, PVC - Assem. Menuiserie, PVC - Vitrage-Expé) dans ces feuilles ne copier que les lignes qui ont une valeur "non" dans la colonne "O"

Merci de votre aide.

Bonjour Jérôme, bonjour le forum,

Si j'ai bien compris... :

Sub Rectangle11_Clic()
Dim TOS As Variant
Dim OT As Worksheet
Dim OS As Worksheet
Dim DerLigne As Integer
Dim nomagence As String

TOS = Array("COMMUN", "PVC - Débit", "PVC - Assem. ferrures", "PVC - Assem. Menuiserie", "PVC - Vitrage-Expé")
Set OS = Worksheets("SYNTHESE")
'EnableEvents pour désactiver provisoirement les évènements
Application.EnableEvents = False
'Application.ScreenUpdating = False
OS.Range("B4:H500").ClearContents
 For I = 0 To UBound(TOS)
   Set OT = worksheeets(TOS(I))
   For lig = 2 To OT.Range("A200").End(xlUp).Row
     If UCase(OT.Cells(lig, "O")) = "NON" Then
       OT.Cells(lig, 1).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 1) 'recopie la valeur de la colonne 1
       OT.Cells(lig, 10).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 2) 'recopie la valeur de la colonne 10
       OT.Cells(lig, 11).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 3) 'recopie la valeur de la colonne 11
       OT.Cells(lig, 12).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 4) 'recopie la valeur de la colonne 12
       OT.Cells(lig, 13).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 5) 'recopie la valeur de la colonne 13
       OT.Cells(lig, 14).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 6) 'recopie la valeur de la colonne 14
       Range("B300").End(xlUp).Offset(1) = OT.Name 'recopie le nom de l'onglet
     End If
   Next lig
 Next I

'Recupere la dernière cellule en colonne B
DerLigne = OS.Cells(Rows.Count, "B").End(xlUp).Row
nomagence = Sheets("PAGE DE GARDE").Range("E15")
'MsgBox (DerLigne)
For I = 4 To DerLigne
    OS.Range("A" & I) = nomagence
    ' on ecris la formule =SI(ESTVIDE(B4);"";nom_Agence)
    'Range("A" & i).FormulaR1C1 = "=IF(ISBLANK(RC[1]),"""",nom_Agence)"
Next

'Appliquer une ecriture de 9 et une mise en forme des cellules
OS.Range("A4:H4").Select
OS.Range(Selection, Selection.End(xlDown)).Select
    'Taille police 9
    With Selection.Font
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
    End With
    'Appliquer une mise en forme des cellules
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Rows("4:" & DerLigne).EntireRow.AutoFit
'definition de la zone d'impression
ActiveSheet.PageSetup.PrintArea = "$A$1:$H$" & DerLigne
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Je viens d'essayer le code et j'ai un petit message d'erreur ?

Re,

Worsheeets !... Il y un e en trop. Remplace Worksheeets par Worksheets...

pourtant j'ai regardé mais pas vu le 3émé "e"

Merci Encore

Re,

L'eusses tu cru, c'était un e frais !...

Thautheme je vais abuser de toi ....

je souhaiterais pour une cellule faire un copier -> Collage spécial "Valeur"

Est ce possible ?

OT.Cells(lig, 10).Resize(, 1).Copy OS.Range("B1000").End(xlUp).Offset(1, 2)

Re,

J'ai modifié la partie concernée, j'espère que je ne me suis pas planté...

Sub Rectangle11_Clic()
Dim TOS As Variant
Dim OS As Worksheet
Dim I As Byte
Dim OT As Worksheet
Dim Lig As Integer
Dim DerLigne As Integer
Dim nomagence As String
Dim LI As Integer
Dim COL As Integer

TOS = Array("COMMUN", "PVC - Débit", "PVC - Assem. ferrures", "PVC - Assem. Menuiserie", "PVC - Vitrage-Expé")
Set OS = Worksheets("SYNTHESE")
'EnableEvents pour désactiver provisoirement les évènements
Application.EnableEvents = False
'Application.ScreenUpdating = False
OS.Range("B4:H500").ClearContents
 For I = 0 To UBound(TOS)
    Set OT = worksheeets(TOS(I))
    COL = 3 'initialise la colonne COL
    For Lig = 2 To OT.Range("A200").End(xlUp).Row
        If UCase(OT.Cells(Lig, "O")) = "NON" Then
            LI = OS.Range("B1000").End(xlUp).Row + 1
            OT.Cells(Lig, 1).Copy OS.Cells(LI, COL): COL = COL + 1 'recopie la valeur de la colonne 1, incrémente COL
            OS.Cells(LI, COL).Value = OT.Cells(Lig, 10).Value: COL = COL + 1 'récupère dans la colonne 10 la valeur de la cellule ligne lig colonne 1 de l'onglet OT, incrémente COL
            OT.Cells(Lig, 11).Copy OS.Cells(LI, COL): COL = COL + 1 'recopie la valeur de la colonne 11, incrémente COL
            OT.Cells(Lig, 12).Copy OS.Cells(LI, COL): COL = COL + 1 'recopie la valeur de la colonne 12, incrémente COL
            OT.Cells(Lig, 13).Copy OS.Cells(LI, COL): COL = COL + 1 'recopie la valeur de la colonne 13, incrémente COL
            OT.Cells(Lig, 14).Copy OS.Cells(LI, COL): COL = COL + 1 'recopie la valeur de la colonne 14, incrémente COL
            Range("B300").End(xlUp).Offset(1) = OT.Name 'recopie le nom de l'onglet
        End If
   Next Lig
 Next I

J'ai un petit message d'erreur lors de l'exécution

.

Re,

Ha oui !... VBA et les cellule fusionnées ne font pas bon ménage !... Quelle est la cellule fusionnée et quelle plage représente-t-elle exactement ?

Je pense que je vais plutôt adapter le code qui se trouve dans la macro 'Avec Feuilles'

.Range("I" & I).Formula = "=F" & I & "*" & "H" & I

je vais indiquer directement le résultat dans la cellule de destination au lieu d'une formule.

Sub AvecFeuilles(Feuille As Worksheet)
Dim DerLigne As Integer

With Feuille
    DerLigne = .Cells(.Rows.Count, 1).End(xlUp).Row 'Si tu veux la dernière cellule en colonne A
    For I = 8 To DerLigne
       .Range("F" & I).Formula = "=D" & I & "*" & "E" & I
       .Range("I" & I).Formula = "=F" & I & "*" & "H" & I
       .Range("O" & I).Formula = "=IF(J" & I & "="""",""OUI"",""NON"")" 'formule =SI(J8="";"OUI";"NON")
    Next

End Sub