Özel yapıştır makrosu

[msetr]

Herkese iyi günler.

Aşağıdaki makro ile kopyala yapıştır yapıyorum. Ama kaynak hücredeki tüm biçimlendirmeleri hedef hücreye aynen yapıştırıyor. Benim istediğim sadece değerleri yapıştırması.

Kendim makro kaydedip koduna baktım forumda da aradım. Ama benim koda tam uyarlayamadım. Değişik yerlere ilave ettim ama kodu tam nereye koyacağımı bulamadım. Bir şeyi eksik yapıyorum ama çözemedim.
Yardımcı olacak arkadaşlara şimdiden teşekkürler.



Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("AN2:AN" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
If Target.Offset(0, 1) <> "AKTARILDI" Then
If WorksheetFunction.CountBlank(Range("A" & a & ":E" & a)) = 0 Then
For sayfa = 1 To Sheets.Count
If Sheets(sayfa).Name = Target Then
yeni = Sheets(sayfa).Cells(Rows.Count, "C").End(3).Row + 1
Range("B" & a).Copy Sheets(sayfa).Cells(yeni, "C")
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
sayfa = Sheets.Count
Target.Offset(0, 1) = "AKTARILDI"

End If
Next
End If

End If

End Sub

 

[PLİNT]

Merhaba
Kodların içindeki ilgili bölümü şöyle düzeltip deneyin.

'...
'....kodlarınız
'....

yeni = Sheets(sayfa).Cells(Rows.Count, "C").End(3).Row + 1
[COLOR="Red"]Range("B" & a).Copy
 Sheets(sayfa).Cells(yeni, "C").PasteSpecial Paste:=xlPasteValues[/COLOR]
sayfa = Sheets.Count
Target.Offset(0, 1) = "AKTARILDI"
'.....
'..
'....diğer kodlar
'....

 

[msetr]

Merhaba
Kodların içindeki ilgili bölümü şöyle düzeltip deneyin.

'...
'....kodlarınız
'....

yeni = Sheets(sayfa).Cells(Rows.Count, "C").End(3).Row + 1
[COLOR="Red"]Range("B" & a).Copy
 Sheets(sayfa).Cells(yeni, "C").PasteSpecial Paste:=xlPasteValues[/COLOR]
sayfa = Sheets.Count
Target.Offset(0, 1) = "AKTARILDI"
'.....
'..
'....diğer kodlar
'....

Sayın PLİNT kod çalışıyor hızlı cevabınız için teşekkürler.

İki ufak sorun var gibi.
Birincisi kopyalanan kaynak hücrenin üzeri seçili olarak kalıyordu. Application.CutCopyMode = False kodunu ilave edip seçili kalma sorunu çözdüm.

İkincisi kod çalışınca ekran tazeleme yapıyor. Ekranda bir hareketlenme oluyor. Önceki kullandığım kodda hareket olmuyordu. Size zahmet ekteki dosyada deneme yaparsanız dediğimi daha iyi anlarsınız umarım. Yardımlarınız için teşekkürler.

 

[PLİNT]

Merhaba
Dosyanıza bakma imkanım yok ama; amaç sadece değeri aktarmak olduğuna göre kopyalamak yerine eşitlemek yeterli görünüyor.

[SIZE="2"]'.....
'.....kodlarınız
'....
If Sheets(sayfa).Name = Target Then
yeni = Sheets(sayfa).Cells(Rows.Count, "C").End(3).Row + 1
[COLOR="Red"]Sheets(sayfa).Cells(yeni, "C").Value = Range("B" & a).Value[/COLOR]
sayfa = Sheets.Count
Target.Offset(0, 1) = "AKTARILDI"
'....
'.....

 [/SIZE]

Kopyalama içinde kodlara aşağıdaki mavi satırları ekleyip deneyebilirsiniz.

[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("AN2:AN" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
If Target.Offset(0, 1) <> "AKTARILDI" Then
If WorksheetFunction.CountBlank(Range("A" & a & ":E" & a)) = 0 Then
For sayfa = 1 To Sheets.Count
If Sheets(sayfa).Name = Target Then
yeni = Sheets(sayfa).Cells(Rows.Count, "C").End(3).Row + 1
[COLOR="Blue"]Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False[/COLOR]
Range("B" & a).Copy
Sheets(sayfa).Cells(yeni, "C").PasteSpecial Paste:=xlPasteValues
[COLOR="Blue"]Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic[/COLOR]
sayfa = Sheets.Count
Target.Offset(0, 1) = "AKTARILDI"
End If
Next
End If
End If
[COLOR="Blue"]Application.CutCopyMode = False[/COLOR]
End Sub [/SIZE]

 

[msetr]

Şimdi problem çözüldü. Çok teşekkürler yardımınız için. İyi günler kolay gelsin.

 

[turgayzeynep]

A13 hücresindeki metni C13 'e farklı olarak yapıştırmak istiyorum otomatik olarak Makro ile bunu nasıl yapabilirim Yardımcı olabilir misiniz hocam rica etsem

 

[ÖmerBey]

A13 hücresindeki metni C13 'e farklı olarak yapıştırmak istiyorum

Merhaba,

Range("C13").Value = Range("A13").Text