Collage en fonction d´un mot

Bonjour,

Je cherche à créer une VBA qui dans la feuille "Client1", cherche sur la colonne B le nom de zone ("Découpe 1", "Découpe 2", "Cuisine") et copie les cellules de la même ligne seulement pour les colonnes C à F. Les cellules copiées seraient collées dans 3 feuilles différentes "Découpe1", "Découpe2", "Cuisine" en fonction de la zone indiquée de la colonne B.

1. J´ai trouvé un code pour le copier/coller ("CopierCondition") mais j´aimerais améliorer la mise en forme du résultat obtenu :

• ne pas copier la colonne B de la feuille "Client1" mais seulement les colonnes C, D, E, F
• ne pas coller la mise en forme du tableau (bordure) mais seulement coller les valeurs
• supprimer les cellules vides.

1. Question : Si je fais "Combiner et centrer" les cellules de la colonne B par zone existe-il un moyen d´adapter le code pour que toutes les cellules des colonnes C à F situées sur le niveau de la zone soient copiées? En effet, avec le code actuel, seule une ligne est copiée.

3. Dans un deuxième temps, j´aimerais que la macro puisse chercher dans une autre feuille "Programme" les clients pogrammés chaque jour, et remplisse dans les feuilles "Découpe1", Découpe2" et "Cuisine" les activités à réaliser.

Pourriez-vous m´éclairer s´il vous plait, surtout pour les points 1 et 2?

En vous remerciant d´avance.

Vous trouverez ci-joint le fichier excel. Voici le code actuel :

Sub CopierCondition()

Dim Rw As Range
Dim Ligne As Long

' Sélection de l´ensemble des données

Sheets("Client1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Cells(1)).Select

' Boucle qui cherche sur chaque ligne le mot voulu et copie dans une deuxième feuille de calcul

For Each Rw In Selection.Rows

Ligne = Rw.Row

If Rw.Cells(1, 2).Value = "Découpe 1" Then
Rw.Copy Destination:=Worksheets("Découpe1").Cells(Ligne, 1).EntireRow

End If

Next Rw

For Each Rw In Selection.Rows

Ligne = Rw.Row

If Rw.Cells(1, 2).Value = "Découpe 2" Then
Rw.Copy Destination:=Worksheets("Découpe2").Cells(Ligne, 1).EntireRow
End If

Next Rw

For Each Rw In Selection.Rows

Ligne = Rw.Row

If Rw.Cells(1, 2).Value = "Cuisine" Then
Rw.Copy Destination:=Worksheets("Cuisine").Cells(Ligne, 1).EntireRow
End If

Next Rw

' Suppression des cellules vides

Dim Cellule As Range
    For Each Cellule In Sheets("Découpe1").Range("B3:H30")
        If Cellule Is Nothing Or Cellule.Value = "" Then
            Cellule.Delete xlUp
        End If
    Next Cellule

    For Each Cellule In Sheets("Découpe2").Range("B3:H30")
        If Cellule Is Nothing Or Cellule.Value = "" Then
            Cellule.Delete xlUp
        End If
    Next Cellule

For Each Cellule In Sheets("Cuisine").Range("B3:H30")
        If Cellule Is Nothing Or Cellule.Value = "" Then
            Cellule.Delete xlUp
        End If
    Next Cellule

End Sub