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