Sadece dolu hücreleri diğer sütuna yapıştırma

[aureliane]

Selamlar herkese, forumda çok araştırdım, vba bilgimin yetersizliğinden kendi çalışmama uyarlayamadım, sizden ricam;

F4 ten başlamak üzere tüm F sütunundaki dolu hücreleri seçerek, G4 ten itibaren G sütununa boş hücreleri atlayarak yapıştırmak.
indis formülüyle yaptığım bir yöntem var ama hesaplaması çok uzun sürüyor.

 

[dEdE]

Aşağıdaki kodları bir modüle kopyalayarak dener misiniz?

Sub Dolu_Kopyala()
Sat = 4
ss = Cells(Rows.Count, "F").End(3).Row
    Range("F4:F" & ss).Select
    For Each Dolu In Selection.SpecialCells(xlCellTypeConstants)
        Cells(Sat, 7) = Dolu
        Sat = Sat + 1
    Next
End Sub

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Kopyala()
    Range("G4:G" & Rows.Count).ClearContents
    Range("F4:F" & Rows.Count).SpecialCells(xlCellTypeConstants, 23).Copy Range("G4")
End Sub

 

[aureliane]

Merhabalar, öncelikle ilgilendiğiniz için sonsuz teşekkürler. F4 sütunumda formüller bulunmakta ve formül sonucu "" ile bazı hücreleri boş göstermekte, bu sebeple olsa gerek her iki kodda hiçbir hücre bulunamadı hatası verdi, formülsüz bir yerde deneme yaptığımda aynı hücreleri aynı boşluklarla G sütununa aktardığını gördüm, benim naçizane ihtiyacım resim de örneklediğim şekilde, normalde ben bunu aşağıdaki formülle yapabiliyorum ama satır sayısı artınca inanılmaz yavaşlıyor.

=EĞERHATA(İNDİS($F$4:$F$1000000;TOPLAMA(15;6;SATIR($F$4:$F$1000000)-SATIR($F$4)+1/($F$4:$F$1000000<>"");SATIRSAY($F4:F$4)));"")

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub List_Filled_Cells()
    Dim S1 As Worksheet, X As Long
    Dim Process_Time As Double
    Dim My_Data As Variant, Count_Row As Long
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Process_Time = Timer
    
    Set S1 = Sheets("Sheet1")
    
    My_Data = S1.Range("F4:F" & S1.Cells(S1.Rows.Count, "F").End(3).Row).Value
    
    ReDim Cell_List(1 To UBound(My_Data, 1), 1 To 1)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "" Then
            Count_Row = Count_Row + 1
            Cell_List(Count_Row, 1) = My_Data(X, 1)
        End If
    Next
    
    S1.Range("G4:G" & S1.Rows.Count).ClearContents
    S1.Range("G4").Resize(Count_Row, 1) = Cell_List
    
    Erase My_Data
    Erase Cell_List
    
    Set S1 = Nothing
    
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00")
End Sub

 

[aureliane]

Çok teşekkürler korhan hocam, tam ihtiyacım olan şekilde elinize sağlık. bu kodla birçok indisli formül olan kısmı temizleyebileceğim.