Discussion :

[Vadorblanc]

Bonjour
Le code copie 20 sheets pour 20 équipes différentes, mais si dans une équipe aucune données n'est rentrée en B15:M, alors j'ai une copie d'une autre ligne erronée, comment modifier ce code ? et comment le simplifier pour ne pas multiplier ces lignes autant de fois pour les 20 équipes.
Merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Module01CopierTrmestre1()
 
With Sheets("Détail Equipe 1 trimestre 1")
   .Range("B15:M" & .Cells(.Rows.Count, "B").End(xlUp).Row).Copy Sheets("Récap trimestre 1").Range("A65536").End(xlUp)(2)
End With
 
With Sheets("Détail Equipe 2 trimestre 1")
   .Range("B15:M" & .Cells(.Rows.Count, "B").End(xlUp).Row).Copy Sheets("Récap trimestre 1").Range("A65536").End(xlUp)(2)
End With
 
With Sheets("Détail Equipe 3 trimestre 1")
   .Range("B15:M" & .Cells(.Rows.Count, "B").End(xlUp).Row).Copy Sheets("Récap trimestre 1").Range("A65536").End(xlUp)(2)
End With
 
 
End Sub

[mercatog]

Bonjour
Il suffit de tester si la dernière ligne remplie est supérieur à 15.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Module01CopierTrmestre1()
 
Copie Sheets("Détail Equipe 1 trimestre 1"), Sheets("Récap trimestre 1")
Copie Sheets("Détail Equipe 2 trimestre 1"), Sheets("Récap trimestre 1")
Copie Sheets("Détail Equipe 3 trimestre 1"), Sheets("Récap trimestre 1")
End Sub
 
Sub Copie(Shs As Worksheet, Shd As Worksheet)
Dim LastLig As Long
 
With Shs
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    If LastLig >= 15 Then .Range("B15:M" & LastLig).Copy Shd.Cells(Shd.Rows.Count, "A").End(xlUp)(2)
End With
End Sub

[Vadorblanc]

Bonjour M Mercatog
Ta proposition fonctionne bien, mais s'il y des lignes vides à l'intérieur de la plage B15 et plus bas, cela copie aussi les lignes vides.
Merci pour ton aide.

[aalex_38]

comment le simplifier pour ne pas multiplier ces lignes autant de fois pour les 20 équipes

Pour bien répondre à cette question, il faudrait connaitre la structure de ton fichier, mais une boucle avec incrémentation est certainement la solution.

Un exemple à adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Dim Sh As Worksheet, i As Integer
For i = 1 to 20
Copie Sheets("Détail Equipe " & i & " trimestre 1"), Sheets("Récap trimestre 1")
Next i

[Vadorblanc]

Bonjour Aalex_38
Merci pour ta proposition, M Mercatog a apporté la solution des Sheets par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Copie Sheets("Détail Equipe 1 trimestre 1"), Sheets("Récap trimestre 1")
Copie Sheets("Détail Equipe 2 trimestre 1"), Sheets("Récap trimestre 1")
Copie Sheets("Détail Equipe 3 trimestre 1"), Sheets("Récap trimestre 1")

Sa proposition me convient très bien avec un code propre et clair.

Reste mon post 2 de 13h36

Merci

Bonjour
J'ai mis un code de M Mercatog pour supprimer les lignes vides et qui fonctionne bien:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Module02SupprimeLigneVide()
 
Dim LastLig As Long
 
Application.ScreenUpdating = False
With Sheets("Récap trimestre 1")
    'On enlève l'éventuel filtre auto
    .AutoFilterMode = False
    LastLig = .UsedRange.Rows.Count
    'on filtre notre plage sur colonne A avec critères 0 ou vide
    .Range("A1:L" & LastLig).AutoFilter Field:=1, Criteria1:=0, Criteria2:="=", Operator:=xlOr
    'Et sur colonne A avec critères 0 ou vide
    'Si au moins une ligne visible suite au filtre, on supprime les lignes visibles
    If .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then _
       .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    'On enlève filtre auto
    .AutoFilterMode = False
End With
End Sub

Maintenant je voudrais un copiage en Spécial valeurs le code ci-dessous:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
With Shs
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    If LastLig >= 15 Then .Range("B15:M" & LastLig).Copy Shd.Cells(Shd.Rows.Count, "A").End(xlUp)(2)
End With

Merci

[casefayere]

Bonsoir, essayes comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If LastLig >= 15 Then Shd.Cells(Shd.Rows.Count, "A").End(xlUp)(2).value = .Range("B15:M" & LastLig).value

[Vadorblanc]

Bonjour Casefayere
Ta proposition ne renvoie qu'une partie...je pense que cette structure élaborée par M Mercatog ne permets pas le collage spécial valeur.
J'ai donc trouvé une solution entre l'enregistreur et une variable qui fonctionne, mais qui me chagrine avec les 2 Sélects qu'il me faut bannir, je n'ai pas réussi à supprimer ses 2 là sans un beugage.
Un grand merci à toi pour ta recherche.
Bien cordialement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sheets("Détail Equipe 1 trimestre 1").Range("B15:M34").Copy
 
            Destination.Activate
            Sheets("Récap trimestre 1").Select
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select 'toute version
            Selection.PasteSpecial Paste:=xlPasteValues 'Collage spécial valeurs

[mercatog]

Bonsoir Vadorblanc
Essais cette proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Copie(Shs As Worksheet, Shd As Worksheet)
Dim LastLig As Long, NewLig As Long
 
With Shs
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    If LastLig >= 15 Then
        NewLig = Shd.Cells(Shd.Rows.Count, "A").End(xlUp) + 1
        Shd.Range("A" & NewLig & ":L" & NewLig + LastLig - 15).Value = .Range("B15:M" & LastLig).Value
    End If
End With
End Sub

[Vadorblanc]

Bonjour Mercatog
J'espère que tu as passé des bonnes vacances car on ne t'a pas vu la semaine dernière. J'ai contourné le collage spécial valeur en l'appliquant directement à toute la sheet source puis en récupérant les données ainsi déjà transformées beaucoup plus facile pour moi. Mon projet est terminé avec ses 26 modules et donne entière satisfactions à tous mes collègues. Je mets ta proposition de coté pour une prochaine application, un grand Merci à toi.
Très cordialement