Makro ile Copy Paste (değer)

[vivident]

Arkadaşlar elimdeki dosyada copy,pasta mantığı ile yapılması gereken bir işlem var. Normal copy,paste makrolarını yapıyorum, ama şurdan başlayarak yapıştır, şu hücre aralığında dolu olana yapıştır mantıklarında biraz sıkıntım var.

1) C1 hücresi her değiştiğinde ;
sayfa1'de D4: D28 arasını önce silecek sonra
sayfa2'de C2:C50 arasını kopyalayıp
sayfa1'in D4 hücresinden başlayarak yapıştıracak (ama formüller gelmeyecek, sadece değerler)

2) sayfa1'de D4: D28 hücrelerinin hangisi dolu ise ; sayfa1'de E2:L2 satırını kopyalarayarak dolu hücrenin satırına yapıştıracak . Örnek uygulama dosya içinde mevcut

 

[vivident]

Kendim sordum kendim cevapladım, gibi oldu ama, ilk problemimi çözdüm, ikincisi için yardım alabilirim

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C1]) Is Nothing Then Exit Sub
Range("D4:D46").ClearContents
Sheets("sayfa2").Range("C2:C50").Copy
Range("D4").PasteSpecial xlPasteValues
End Sub

 

[YUSUF44]

2. isteğiniz için E4 hücresine aşağıdaki formülü yapıştırıp daha sonra E4'ü kopyalayıp diğer hücrelere Özel Yapıştır/Formülleriyle çoğaltabilirsiniz;

=EĞER($D4="";"";E$2)

 

[vivident]

Yusuf bey formül istemiyorum. Makro ile bir çözüm bulmam lazım

 

[YUSUF44]

Kendi çözümünüze ilave mi olsun, yani otomatik mi güncellensin yoksa bir düğme vs aracılığıyla mı yapılsın?

Bir de D sütununda sadece ilk dolu hücre için mi yazılacak yoksa o sütundaki tüm dolu satırların karşısına mı veri gelecek? Bir önceki kopyalamadan kalan veriler ne olacak?

 

[vivident]

Otomatik güncellense süper olur Yusuf bey

 

[YUSUF44]

Bir de D sütununda sadece ilk dolu hücre için mi yazılacak yoksa o sütundaki tüm dolu satırların karşısına mı veri gelecek? Bir önceki kopyalamadan kalan veriler ne olacak?

Ayrıca satırları karıştırmışsınız, D28 mi, D46 mı D 50 mi olacak?

 

[vivident]

1) O sütundaki tüm dolu hücreler, boş olan hücrelerde copy paste olmayacak
2) Bir önceki kopyalamadan kalan verileri ben üstteki koda göre Range("D4:L46").ClearContents olarak değiştiririm. hepsini siler
3) Satır sayısı farketmez D46 olsun

XXX yalnız şöyle bir şey aklıma geldi. Biz E2:L2 arasını yapıştırdık. Daha sonra E2:L2 arasında hücrelerden biri değişti. O değişkenlikte diğer satırlara yansıması gerekecek

 

[karotis]

Ekteki dosyayı inceleyebilir misiniz?

 

[vivident]

Karotis bey problem var gibi duruyor ama veya ben yapamadım
Dosyayı sizin yazdığınız kodlarla benim kodu birlikte uyguladım. Çalıştıramadım. Rica etsem inceleyebilirmisiniz

 

[YUSUF44]

Aşağıdaki şekilde deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C1]) Is Nothing Then Exit Sub
Range("D4:L46").ClearContents
Sheets("sayfa2").Range("C2:C50").Copy
Range("D4").PasteSpecial xlPasteValues
For i = 4 To 46
If Cells(i, "d") <> "" Then
For j = 5 To 12
Cells(i, j).FormulaR1C1 = "=R[-" & i - 2 & "]C"
Next
End If
Next
End Sub

 

[karotis]

kendi kodunuzun altına Call cpy yazarsanız sorun çözülecektir

 

[vivident]

kendi kodunuzun altına Call cpy yazarsanız sorun çözülecektir

Kodunuz çalıştı, fakat ;
Sadece değerler değil, biçimler falan hepsini kopyalayıp yapıştırıyor
Birde 28. satırdan sonra kopyalama olmadı

 

[vivident]

Yusuf bey sizin de kodunuz çalıştı. Sadece değerleri kopyalama işi olamaz mı ? Formül kopyalıyor ya, o yüzden söyledim
=E2
=F2
...VB

Aşağıdaki şekilde deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C1]) Is Nothing Then Exit Sub
Range("D4:L46").ClearContents
Sheets("sayfa2").Range("C2:C50").Copy
Range("D4").PasteSpecial xlPasteValues
For i = 4 To 46
If Cells(i, "d") <> "" Then
For j = 5 To 12
Cells(i, j).FormulaR1C1 = "=R[-" & i - 2 & "]C"
Next
End If
Next
End Sub

 

[vivident]

Birde Yusuf bey çok isteğim oldu, özür diliyorum ama, adım adım kopyala, yapıştır yapıyor, şöyle bir kerede, kopyala yapıştır yapamaz mı ?

 

[karotis]

50. satıra kadar sadece value değer olarak şu kod işinize yarayacaktır.

Sub cpy()
Dim wa As Workbook
Dim s1 As Worksheet
Dim r1 As Range
Dim r2 As Range
Dim t%
Set wa = ThisWorkbook
Set s1 = wa.Sheets(1)
Set r1 = s1.Range("E2:L2")
For t = 4 To 50
    If s1.Cells(t, 4) <> "" Then
    
    r1.Copy
    s1.Cells(t, 5).PasteSpecial xlValues
    End If
Next t
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C1]) Is Nothing Then Exit Sub
Range("D4:L46").ClearContents
Sheets("sayfa2").Range("C2:C50").Copy
Range("D4").PasteSpecial xlPasteValues
Call cpy
End Sub

 

[vivident]

Karotis bey elinize sağlık, çok güzel çalışıyor.
Yalnız 5. mesajımda şöyle bir değişiklik istemiştim Yusuf beyden
Bunu makroya dahil edebilirmiyiz.

XXX yalnız şöyle bir şey aklıma geldi. Biz E2:L2 arasını yapıştırdık. Daha sonra E2:L2 arasında hücrelerden biri değişti. O değişkenlikte diğer satırlara yansıması gerekecek

 

[karotis]

If Intersect(Target, [C1]) Is Nothing Then Exit Sub

Satırını aşağıdaki gibi değiştiriniz.

 If Intersect(Target, [C1]) Is Nothing And Intersect(Target, Range("E2:L2")) Is Nothing Then Exit Sub

 

[vivident]

Bu nasıl bir hızdır
Karotis bey, Yusuf bey ayrı ayrı teşekkür ediyorum. Ellerinize sağlık, çok sağolun