Seçilen iki hücre değerini yer değiştirme

[rmzn422]

s.a , başlıktada belirttiğim gibi , excel de, seçtiğim iki farklı hücredeki değerlerin birbiri ile yer değiştirmesini istiyorum. bunu yapmanın basit bir yolu var mı ? eğer yoksa kod yazarak nasıl yapabilirim. (tek tek kopyala yapıştır yapmak çok vaktimi alıyor. ) şimdiden tşkrler.

 

[Necdet]

Merhaba,

Sorunuzu örnek dosya ile destekleyiniz.

 

[rmzn422]

A1 Hücresinde "balık" yazdığını varsayalım, A4 hücresindede "tava" yazsın. Ben A1 VE A4 Hücresini aynı anda seçip ,bir komut veya düğme ile değerlerinin yer değişmesini istiyorum. A1 "tava"- A4 "balık" olacak yani. tşkrler

 

[rmzn422]

çok mu karmaşık acaba.

 

[Muhammet Okumuş]

Merhaba,
Kendimce ilkel bir şeyler yaptım.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Cells(1, 1000) <> "" Then GoTo 10
Cells(1, 1000) = ActiveCell.Address
Exit Sub
10
Cells(2, 1000) = ActiveCell.Address
x = Range(Cells(1, 1000).Text).Text
y = Range(Cells(2, 1000).Text).Text
Range(Cells(2, 1000).Text) = x
Range(Cells(1, 1000).Text) = y
Cells(1, 1000) = ""
Cells(2, 1000) = ""
End Sub

 

[rmzn422]

Muhammet ilgin için tşkler ama nasıl çalıştıracağımı anlayamadım.

 

[Muhammet Okumuş]

Verlerinizi Sayfa1'e kopyalayın. Daha sonra hücrelerin üzerine tıklayacaksınız.

 

[rmzn422]

örnek dosya

 

[Muhammet Okumuş]

Hocam dosyayı bilgisarınıza kaydedin. Makroları etkin kılın. Sarı ile Yeşil renkli hücreler değişen hücreleri gösteriyor.

 

[rmzn422]

çok teşekkürler, elinize sağlık

 

[Ömer]

Merhaba,

Alternatif olarak kullanabilirsiniz.

-----------------------------------------------------------------
Kodları module kopyalayın ve çalışma kitabını kaydetip kapatın.

Bu işlemden sonra kitabı açtığınız zaman, fare sağ kilik menüsüne ""Yeni--->Yer Değiştir"
olarak yeni bir seçenek eklendiğini görebilirsiniz.

Herhangi 2 hücreyi seçip seçili alan üzerinde sağ klik yaptıktan sonra bu seçeneği işaretlediğiniz de seçili 2 hücre yer değiştirir.

Sub Auto_Open()
     FareMenu
End Sub
 
 Sub FareMenu()
 
     Dim cb As CommandBar, MenuObject
 
    Set cb = Application.CommandBars("Cell")
    Set MenuObject = cb.Controls.Add(Type:=msoControlButton, Temporary:=True)
 
     With MenuObject
             .OnAction = "Degis"
             .FaceId = 9
             .Caption = "Yeni--->Yer Değiştir"
     End With
 
     Set cb = Nothing: Set MenuObject = Nothing
 
End Sub
 
Sub Degis()
    Dim a As String, b As String, c, d
 
    Application.ScreenUpdating = False
    On Error Resume Next
 
    With Selection
        If .Count <> 2 Then Exit Sub
        a = Split(.Address, ",")(0)
        b = Split(.Address, ",")(1)
    End With
 
    c = Range(a): d = Range(b)
    Range(a) = d: Range(b) = c
 
    Application.ScreenUpdating = True
 
End Sub
 
 Sub Auto_Close()
     Application.CommandBars("Cell").Reset
 End Sub

 

[scr3w]

hocam bunun kısa yol tuşu yokmudur ? saygılar.

 

[cellatzade46]

@Ömer Hocam Merhabalar. Bu önerinizi sağ klik değilde bir butona nasıl atayabiliriz?

Ayrıca diğer tecrübeli üyelerinde ayrdım edebilmesi adına, örnek dosyamda soldaki kenarlık içine aldığım değerlerle sağdaki kenarlık içine aldığım değerleri nasıl yer değiştirebilirim kolayca? Makro kaydederek ilgili bölmeleri boş bir alana kopyalayıp daha sonra yerlerine yapıştırarak yapabilirim ama bunun başka yöntemi var mıdır?

 

[ozan_ismail]

Merhaba,

Alternatif olarak kullanabilirsiniz.

-----------------------------------------------------------------
Kodları module kopyalayın ve çalışma kitabını kaydetip kapatın.

Bu işlemden sonra kitabı açtığınız zaman, fare sağ kilik menüsüne ""Yeni--->Yer Değiştir"
olarak yeni bir seçenek eklendiğini görebilirsiniz.

Herhangi 2 hücreyi seçip seçili alan üzerinde sağ klik yaptıktan sonra bu seçeneği işaretlediğiniz de seçili 2 hücre yer değiştirir.

Sub Auto_Open()
     FareMenu
End Sub

Sub FareMenu()

     Dim cb As CommandBar, MenuObject

    Set cb = Application.CommandBars("Cell")
    Set MenuObject = cb.Controls.Add(Type:=msoControlButton, Temporary:=True)

     With MenuObject
             .OnAction = "Degis"
             .FaceId = 9
             .Caption = "Yeni--->Yer Değiştir"
     End With

     Set cb = Nothing: Set MenuObject = Nothing

End Sub

Sub Degis()
    Dim a As String, b As String, c, d

    Application.ScreenUpdating = False
    On Error Resume Next

    With Selection
        If .Count <> 2 Then Exit Sub
        a = Split(.Address, ",")(0)
        b = Split(.Address, ",")(1)
    End With

    c = Range(a): d = Range(b)
    Range(a) = d: Range(b) = c

    Application.ScreenUpdating = True

End Sub

Sub Auto_Close()
     Application.CommandBars("Cell").Reset
End Sub

Verdiğiniz kodlarda iki hücreyi seçip değiştir dediğimde iki hücredeki verileri de siliyor.