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
veri = s1.Range("D2
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
End With
.Range("F2").PasteSpecial Paste:=xlPasteValues
.Range("F2").Select
End With
son:
Application.CutCopyMode = False
End Sub