Click ile veri kopyalama.

[simetri.]

Merhabalar değerli uzman arkadaşlar.

Aşağıda ki şekilde, bir kopyalama işlemi yapmaya çalışıyorum.
Değerli bilgilerinizi yardım olarak talep ediyorum.

Yapılacak işlem şu şekilde olacak:

Sarı boyalı alandaki herhangi bir hücreye tıkladığımız
zaman o alanı kopya edecek.

Akabinde renksiz bir alana tıklarsak ilgili kopya iptal
edilecek.

Eğer ki sarı boyalı alana tıklayıp hemen ardından mavi boyalı
alandaki bir hücreye tıklar isek kopyaladığı veriyi, mavi boyalı
alanda ki o hücreye değer olarak yapıştıracak.

Yardımlarınız için şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

Sayfanın kod bölümüne kopyalayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    If Not Intersect(Target, Range("F3:F10")) Is Nothing Then
        Selection.Copy
    End If
 
    On Error Resume Next
    If Not Intersect(Target, Range("H3:H21")) Is Nothing Then
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        Application.CutCopyMode = False
    End If
 
    If Intersect(Target, Range("F3:F10,H3:H21")) Is Nothing Then
        Application.CutCopyMode = False
    End If
 
End Sub

.

 

[simetri.]

Çok teşekkür ederim Ömer Hocam.

Ellerinize sağlık.

 

[simetri.]

Merhabalar Ömer hocam.

Kod üzerinde biraz değişiklik yapmamız mümkünmü acaba?
Kod kusursuz çalışıyor, lakin kod kendi hücre adreslerinde
başka işleme izin vermiyor. Kopyalama yapıştırma vs gibi.

Bunun için click yapılan hücre adreslerini değiştirir isek sorun kalmaz
diye düşünüyorum. Örnek dosyada nasıl olması gerektiği yönünde fikrimi yazdım.
Bakabilirseniz şayet çok sevinirim hocam. Teşekkür ederim.

 

[Ömer]

İstediğiniz bu mu?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    If Not Intersect(Target, Range("G3:G10")) Is Nothing Then
        Selection.Offset(0, -1).Copy
    End If
 
    On Error Resume Next
    If Not Intersect(Target, Range("H3:H21")) Is Nothing Then
        Target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        Application.CutCopyMode = False
    End If
 
    If Intersect(Target, Range("G3:G10,H3:H21")) Is Nothing Then
        Application.CutCopyMode = False
    End If
 
End Sub

.

 

[simetri.]

Aynen budur hocam.
Çok çok teşekkür ederim
tekrardan. Ellerinize sağlık.