Eğer D2 den itibaren olanları kaopyalaacaksanız alttaki kodu kullanabilirsiniz.
Örnek dosya yerine resim eklemişsiniz.

Sub DOLU_HUCRELERI_KOPYALA()

Dim Veri As Range, Alan As Range





For Each Veri In Sheets("Mahalle").Range("D210001")

If Veri.Value <> "" Then

If Alan Is Nothing Then

Set Alan = Veri

Else

Set Alan = Application.Union(Alan, Veri)

End If

End If

Next

With Sheets("Veri")

    .Range("F2:F" & Rows.Count).ClearContents

    .Range("F2").Resize(Alan.Rows.Count, 1) = Alan.Value

    .Select

    .Range("F2").Select

End With

Application.CutCopyMode = False

End Sub