Public Sub CopyFrom3To2()
    Const sSQL = "Select * From [Лист3$] Where [Периодичность] = 'Круглогодично';"
    Const baseConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=%1;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';"
    Dim pConn As Object
    Dim pRSet As Object
    Set pConn = CreateObject("ADODB.Connection")
    pConn.Open Replace$(baseConnStr, "%1", ThisWorkbook.FullName)
    Set pRSet = CreateObject("ADODB.Recordset")
    pRSet.Open sSQL, pConn
    ThisWorkbook.Worksheets("Лист2").Range("A2").CopyFromRecordset pRSet
    pRSet.Close
    pConn.Close
End Sub

Sub Артём_Федотенко()
Dim i As Long, lr As Long, sh As Worksheet, sh2 As Worksheet, col As New Collection
Set sh = Worksheets("Лист1"): Set sh2 = Worksheets("Лист3")
lr = sh2.Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lr
    On Error Resume Next
    col.Add sh2.Cells(i, 2), CStr(sh2.Cells(i, 2))
Next i
ReDim arr(1 To col.Count, 0)
For i = 1 To col.Count
    arr(i, 0) = col(i)
Next i
sh.Range("B5").Resize(UBound(arr), 1) = arr
End Sub