Macroda değişiklik

[yyhy]

Sayfa4(Mahalle) isimli sayfamda bulunan
Sub DOLU_HUCRELERI_KOPYALA()
Dim Veri As Range, Alan As Range

For Each Veri In 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

If Not Alan Is Nothing Then Alan.Copy
End Sub
Yukarıdaki kod ile verileri kopyalıyorum Sayfa1(Veri) sayfası F2 hücresine değerleri yapıştır ve önceki sayfanın seçili kısmını kaldırıma (seçimi iptal) olarak nasıl ekleriz.

 

[yyhy]

Macro bu sayfada düzgün gözükmüyor resim olarak macronun görüntüsünü ekliyorum.

 

[YUSUF44]

Örnek dosya olmadığından deneyemedim. Aşağıdaki gibi olabilir:

Sub DOLU_HUCRELERI_KOPYALA()
Dim Veri As Range, Alan As Range

For Each Veri In Range("D210001")
If Veri.Value <> "" Then
If Alan Is Nothing Then
Set Alan = Veri
Veri.ClearContents
Else
Set Alan = Application.Union(Alan, Veri)
Veri.ClearContents
End If
End If
Next

If Not Alan Is Nothing Then Alan.Copy Sheets("Veri").[F2]
End Sub

 

[yyhy]

Sayın @YUSUF44 aceleye geldi dosya ekleyelemiştim. Deneyeyim olmazsa dosya hazırlayıp tekrar atayım. Teşekkürler.

 

[yyhy]

Örnek dosya ekliyorum. Verinin olduğu sayfadaki verileri siliyor macroya tekrar bakabilir misiniz?

 

[Korhan Ayhan]

Dosyanızda VBA koruması var.

 

[yyhy]

Hemen ekliyorum özür dilerim.

 

[YUSUF44]

D sütununu kullanmadan doğrudan B sütunundan verileri alarak hazırladığım aşağıdaki kodu deneyin:

Sub DOLU_HUCRELERI_KOPYALA()
Set s1 = Sheets("Mahalle")
Set s2 = Sheets("Veri")

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

For i = 2 To son
    yeni = s2.Cells(Rows.Count, "F").End(3).Row + 1
    s2.Cells(yeni, "F") = Left(s1.Cells(i, "B"), WorksheetFunction.Search("Mah.", s1.Cells(i, "B")) + 4)
Next
End Sub

 

[yyhy]

Sayın @YUSUF44 ihtiyaca cevap verdi elinize sağlık. Teşekkür ederim.