Option Compare Text
Private Sub CommandButton1_Click()
Dim i As Long, k As Long, x As Integer, j As Integer
Dim tablo()
x = 0
For k = 1 To Sheets.Count
ReDim Preserve tablo(x)
tablo(x) = Sheets(k).Name
x = x + 1
Next
For i = 1 To Range("B65536").End(xlUp).Row
If Range("B" & i).Value <> "" Then
For j = LBound(tablo) To UBound(tablo)
If InStr(1, Range("B" & i).Value, tablo(j)) <> 0 Then
With Sheets(tablo(j))
Range("A" & i).Resize(1, 3).Copy .Range("A" & .Range("A65536").End(xlUp).Offset(1, 0).Row)
End With
End If
Next
End If
Next
End Sub