copiare cella su condizione

Private Sub Worksheet_Activate()
Dim wkFr As Worksheet, wkTo As Worksheet, i As Integer, ur As Integer, r As Integer
Set wkFr = Worksheets("Foglio1")
Set wkTo = Worksheets("Foglio2")
wkTo.Range("A2:A" & Rows.Count).ClearContents
ur = wkFr.Range("A" & Rows.Count).End(xlUp).Row
r = 2
For i = 2 To ur
    If wkFr.Cells(i, 3) = "SI" Then
        wkTo.Cells(r, 1) = wkFr.Cells(i, 1)
        r = r + 1
    End If
Next
Set wkFr = Nothing
Set wkTo = Nothing
End Sub