Une boucle qui transferts les donner une seule fois

Bonjour, j'ai créée un programme dans Excel 2007 pour transferts les donner de la feuille 1 à la feuille 2 et 3 suivent une condition.
J'ai fais un bouton avec VBA qui transferts les donner, mai chaque fois quand je click sur CommandButton1 ce répète plusieurs fois
Je veux une boucle qui transferts les donner une seule fois
Voilà mon code:
Private Sub CommandButton1_Click()
Dim cl As Range, i As Integer
For i = 2 To 3
For Each cl In Range("H4:H" & [H10000].End(xlUp).Row)
If cl.Value = Sheets(i).Name Then
cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("B" & Sheets(i).[B10000].End(xlUp).Row + 1)
End If
Next cl
Next i
MsgBox "Transfert apte et inapte", vbOKOnly, "Transfert"

'MsgBox "Vous ne pouvez pas transfert à nouveau", vbOKOnly, "Transfert"
End Sub