Yada başka yöntem galiba en ideal bu.

If Not Alan Is Nothing Then Alan.Copy .Range("F2")

Yukardaki kod aktarıyor. Tabi hücreler arasında boşluk olunca hata veriyor.
Örnek eklerseniz başka yöntemlede bakarız.

Sub DOLU_HUCRELERI_KOPYALA()

Dim Veri As Range, Alan As Range



For Each Veri In Sheets("Mahalle").Range("D2:E10001")

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:G" & Rows.Count).ClearContents

    If Not Alan Is Nothing Then Alan.Copy .Range("F2")

    .Select

    .Range("F2").Select

End With

Application.CutCopyMode = False

End Sub

Sayın @feraz bey ihtiyaca cevap verdi. Elinize sağlık teşekkür ederim. Dosya hazırlamaya zamanım olmadı acele ile attım. Yine de çok teşekkürler.

(28/04/2020, 00:05)yyhy yazdı: Sayın @feraz bey ihtiyaca cevap verdi. Elinize sağlık teşekkür ederim. Dosya hazırlamaya zamanım olmadı acele ile attım. Yine de çok teşekkürler.

Rica ederim.
Sizin döngülü yöntem harici bir kod yazdım isterseniz bunuda deneyebilirsiniz.

Const kaydir As Integer = 3

Yukaradaki 3 demek mesela D:G aralığındaki veriler alınacaksa için.
D:I aralık olsaydı 5 yazılacktı.

Sub DOLU_HUCRELERI_KOPYALA()

    Const kaydir As Integer = 3

    Dim syf_Mahalle As Worksheet

    Set syf_Mahalle = Sheets("Mahalle")



    With Sheets("Veri")

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

        syf_Mahalle.Range("D2", syf_Mahalle.Range("D2").Offset(10001, kaydir)).Copy .Range("F2")

        .Range("F2", .Range("F2").Offset(10001, kaydir)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

    End With

    Application.CutCopyMode = False

    Set syf_Mahalle = Nothing

End Sub

Aceleden dolayı örnek dosya eklememiştim, hata etmişim örnek dosyayı ekliyorum. Örnek dosya üzerinde denedim macro formüllü olan kısmı getirip yapıştırıyor değerleri yapıştırmasını istiyorum.

(01/05/2020, 01:03)yyhy yazdı: Aceleden dolayı örnek dosya eklememiştim, hata etmişim örnek dosyayı ekliyorum. Örnek dosya üzerinde denedim macro formüllü olan kısmı getirip yapıştırıyor değerleri yapıştırmasını istiyorum.

Sub Dolu()

    

  Dim veri, arr, say As Long, i As Long, son As Long

  Dim s1 As Worksheet: Set s1 = ThisWorkbook.Sheets("Mahalle")

  Dim s2 As Worksheet: Set s2 = ThisWorkbook.Sheets("Veri")

  

    son = s1.Cells(Rows.Count, "D").End(3).Row

    If son = 1 Then son = 2

    If WorksheetFunction.CountA(s1.Range("D2" & son)) = 0 Then GoTo var

    veri = s1.Range("D2" & son).Value

    ReDim arr(1 To UBound(veri), 1 To 1)

    For i = LBound(veri) To UBound(veri)

        If veri(i, 1) <> "" Then

            say = say + 1

            arr(say, 1) = veri(i, 1)

        End If

    Next

var:

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

    If say > 0 Then

        s2.Range("F2").Resize(say, 1).Value = arr

    End If

    

  On Error Resume Next

  Set s1 = Nothing

  Set s2 = Nothing

  Erase veri: Erase arr

End Sub

Eğer sadece formül varsa alttaki koduda deneyebilirsiniz kısa olması açısından.

Tabii benim tercihim ilk verdiğim kod olurdu.

Sub Test()

    

    With Sheets("Veri")

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

        On Error GoTo son

        With Sheets("Mahalle")

            .Range("D2" & .Cells(Rows.Count, "D").End(3).Row).SpecialCells(xlCellTypeFormulas, 23).Copy

        End With

    

        .Range("F2").PasteSpecial Paste:=xlPasteValues

        .Range("F2").Select

    End With

son:

    Application.CutCopyMode = False

End Sub