Skip to main content

AccessTr.neT


Macroda Değişiklik

Macroda Değişiklik

#7
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
Cevapla
#8
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.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#9
(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
Cevapla
#10
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.
.rar Mahalle.rar (Dosya Boyutu: 60,57 KB | İndirme Sayısı: 2)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#11
(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("D2Lol" & son)) = 0 Then GoTo var
    veri = s1.Range("D2Lol" & 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
Cevapla
#12
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("D2Lol" & .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
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da