Makro ile kopyalama

[kemalist]

Arkadaşlar Merhaba;Benim yapmak istediğim elimde "DATA" isminde bir dosya var.Burada B4 hücresinde bulunan "R" sayfasından "B4:B403" hücrelerini kopyalayıp "N4" hücresindeki "A" sayfasında "CE6 ve CV6 "ya PasteSpacial olarak yapıştırmak. Kopyalanacak ve yapıştırılacak hücreleri bu sayfadan seçmek gerekli.Devamındada aynı işlemi Next döngüsüyle alt satırlara uygulamak.Bunu makro ile nasıl yapabiliriz?İlginiz için şimdiden teşekkür ederim.Örnek dosya ektedir.

 

[vardar07]

Yanlış anlamadıysam. Deneyiniz.

Sub aktar()
With Sheets("Sayfa1")
For m = 4 To 8
c = .Cells(m, "B"): d = .Cells(m, "N")
Set sk = Sheets(c): Set sy = Sheets(d)
a = .Cells(m, "I") & ":" & .Cells(m, "K")
b = .Cells(m, "V") & ":" & .Cells(m, "X")
sk.Range(a).Copy sy.Range(b)
Next m
End With
End Sub

 

[kemalist]

Sayın Vardar07 "Outoff Range " olarak hata veriyor.Siz örnek dosya üzerinde denermisiniz?

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.
.

[FONT="Arial Narrow"][B]Sub KOPYALA()[/B]
Set s1 = Sheets("Sayfa1")
For sat = 4 To s1.[B65536].End(3).Row
[COLOR="Red"]'*** [B][COLOR="Red"]k[/COLOR][/B] kısaltması KAYNAK anlamında, [B][COLOR="red"]h[/COLOR][/B] kısaltması ise HEDEF anlamındadır.[/COLOR]
On Error GoTo 10
    Set [B][COLOR="Red"]k[/COLOR][/B]sayfa = Sheets(s1.Cells(sat, "B").Value)
        [B][COLOR="Red"]k[/COLOR][/B]ilk = s1.Cells(sat, "I").Value
        [B][COLOR="Red"]k[/COLOR][/B]son = s1.Cells(sat, "K").Value
    
    Set [B][COLOR="red"]h[/COLOR][/B]sayfa = Sheets(s1.Cells(sat, "N").Value)
        [B][COLOR="red"]h[/COLOR][/B]bir = s1.Cells(sat, "V").Value
        [B][COLOR="red"]h[/COLOR][/B]iki = s1.Cells(sat, "X").Value
    [COLOR="Blue"]ksayfa.Range(kilk & ":" & kson).Copy: hsayfa.Range(hbir).PasteSpecial Paste:=xlPasteValues[/COLOR]
    [COLOR="blue"]ksayfa.Range(kilk & ":" & kson).Copy hsayfa.Range(hiki).PasteSpecial Paste:=xlPasteValues[/COLOR]
10
Next: ksayfa = Empty: hsayfa = Empty
MsgBox "İşlem tamamlandı..", vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B][/FONT]

 

[vardar07]

Sayın Vardar07 "Outoff Range " olarak hata veriyor.Siz örnek dosya üzerinde denermisiniz?

Onun sebebi N8 hücresindeki E harfinin sağında boşluk varmış ondan oluyor.
Bu satırı aşağıdaki ile değiştirin. Yada E harfinin sağındaki boşluğu silip deneyin.

c = .Cells(m, "B"): d = .Cells(m, "N")

c = Trim(.Cells(m, "B")): d = Trim(.Cells(m, "N"))

 

[Ömer BARAN]

Aynen Sayın vardar haklıdır.
Kolay gelsin.

 

[kemalist]

Ömer Bey Merhaba ilginize teşekkür ederim.Tek eksiğimiz en alt satırı yani sayfa1 deki 8. satırdakilere uygulamıyor.

 

[Ömer BARAN]

Son satırda N8 hücresindeki E harfinden sonraki boşluk karakteri ile ilgili olarak,
Sayın vardar'ın son cevabındaki uyarıyı dikkate alınız.

 

[kemalist]

Yanlış anlamadıysam. Deneyiniz.

Sub aktar()
With Sheets("Sayfa1")
For m = 4 To 8
c = .Cells(m, "B"): d = .Cells(m, "N")
Set sk = Sheets(c): Set sy = Sheets(d)
a = .Cells(m, "I") & ":" & .Cells(m, "K")
b = .Cells(m, "V") & ":" & .Cells(m, "X")
sk.Range(a).Copy sy.Range(b)
Next m
End With
End Sub

sayın vardar07 yapıştırma işlemi iki ayrı kücreye olacak burada iki hücre arasındaki tüm hücrelere yapıyor. Dikkat edilirse hücreler arasını ; (noktalı virgül) ile belirtmiştim.

 

[Ömer BARAN]

Sayın kemalist,
-- N8 hücresindeki boşluk karakterini silerek
-- veya
Set hsayfa = Sheets(s1.Cells(sat, "N").Value)
satırını
Set hsayfa = Trim(Sheets(s1.Cells(sat, "N").Value))
şeklinde değiştirerek
benim gönderdiğim kod'u kullanabilirsiniz.
.

 

[vardar07]

Ömer Bey'inde eline sağlık. Düzeltilmiş şekli aşağıda istediğinizi kullanınız. Fazla alternatifden zarar gelmez.

Sub aktar()
With Sheets("Sayfa1")
For m = 4 To 8
a = Trim(.Cells(m, "B")): b = Trim(.Cells(m, "N"))
Set sk = Sheets(a): Set sy = Sheets(b)
c = .Cells(m, "I") & ":" & .Cells(m, "K")
d = .Cells(m, "V"): e = .Cells(m, "X")
sk.Range(c).Copy sy.Range(d)
sk.Range(c).Copy sy.Range(e)
Next m
End With
End Sub

 

[kemalist]

Sayın Vardar07 ve Sayın Ömer Bey ilgi ve alakanıza teşekkür ederim.İşlem tamam..

 

[kemalist]

Ömer Bey'inde eline sağlık. Düzeltilmiş şekli aşağıda istediğinizi kullanınız. Fazla alternatifden zarar gelmez.

Sub aktar()
With Sheets("Sayfa1")
For m = 4 To 8
a = Trim(.Cells(m, "B")): b = Trim(.Cells(m, "N"))
Set sk = Sheets(a): Set sy = Sheets(b)
c = .Cells(m, "I") & ":" & .Cells(m, "K")
d = .Cells(m, "V"): e = .Cells(m, "X")
sk.Range(c).Copy sy.Range(d)
sk.Range(c).Copy sy.Range(e)
Next m
End With
End Sub

Sayın vardar07 ve Ömer Bey;kod deneme sayfasında başarılı bir şekilde çalıyor.Fakat başka bir dosyaya uyarlamaya çalıştığımda hata veriyor.Resmi yolluyorum.

 

[Ömer BARAN]

Tekrar merhaba.

Eklediğiniz ekran görüntüsü benim cevabımdaki kod'a ait değil.
Onunla ilgili olarak Sayın vardar cevap yazacaktır.

Benim verdiğim kod için değiştirilebilecek şey olarak; kopyalanan alanda formül olması halini dikkate alıp
yapıştırma işleminin DEĞERleri şeklinde değiştirilmesi olabilir.
(hücredeki BOŞLUK karakteriyle ilgili durumu yok sayıyorum)

Verdiğim kod'da (önceki cevabımı güncelledim, sayfayı yenileyerek kontrol edin)
mavi kısımları yeni haliyle kullanarak denemenizi önerebilirim.
.

 

[vardar07]

Bende problem yok hata veren dosyayı format ını sayfa adlarını bozmadan ekleyin bir bakalım.

 

[kemalist]

Teşekkürler işlem tamam..

 

[Ömer BARAN]

Teşekkürler işlem tamam..

Kolay gelsin.
.