Sub CopyCells()
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim data As Variant
Dim results As Collection
Dim colors As Collection
Dim prefix As Variant
Dim prefixes As Variant
Dim i As Long
Dim j As Long
Dim nextRow As Long
' Feuille source
Set wsSource = ThisWorkbook.Sheets("Base de données")
' Lire toutes les données dans un tableau en mémoire
data = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value
' Définir les préfixes à vérifier
prefixes = Array("CC", "CB", "CHU")
' Parcourir chaque préfixe
For Each prefix In prefixes
' Créer une nouvelle collection pour stocker les résultats et les couleurs pour ce préfixe
Set results = New Collection
Set colors = New Collection
' Parcourir chaque ligne de données
For i = 1 To UBound(data, 1)
' Si la cellule commence par le préfixe actuel, ajouter la ligne et la couleur au tableau de résultats
If Left(data(i, 1), Len(prefix)) = prefix Then
results.Add Array(data(i, 1), data(i, 2), data(i, 3))
colors.Add wsSource.Cells(i + 1, "A").Interior.Color
End If
Next i
' Si des résultats ont été trouvés, les écrire sur la feuille de destination
If results.Count > 0 Then
' Feuille de destination
Set wsDestination = ThisWorkbook.Sheets(prefix)
' Trouver la première ligne vide dans la colonne A de la feuille de destination
nextRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
' Écrire les résultats et les couleurs sur la feuille de destination
For i = 1 To results.Count
For j = 1 To 3
With wsDestination.Cells(nextRow + i - 1, j)
.Value = results(i)(j - 1)
.Interior.Color = colors(i)
End With
Next j
Next i
End If
Next prefix
End Sub
