Sütundaki hücrelerdeki bilgilerin ENTER ile başka bir hücreye gönderilmesi

[Tevfik_Kursun]

Merhaba Arkadaşlar,
B4 ve altındaki hücrelerde bulunan ifadelerin, o hücrelerde ENTER'e basıldığında E4 hücresine gönderilmesi ile ilgili makroya ihtiyacım var.
(hem copy, hem de move durumlarına göre ayrı ayrı)
Saygılarımla

 

[ÖmerFaruk]

(hem copy, hem de move durumlarına göre ayrı ayrı)

Bu kısmı anlamadım.

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
O noktayı iki farklı makro gibi düşünün lütfen.
Makro1 : copy yapacak, aynı ifade bir daha kullanılabilir
Makro2 : move yapacak, aynı ifade bir daha kullanılamaz
Saygılarımla

 

[ÖmerFaruk]

1. durumda (Copy)
B4 ve altında hücreye bir ifade yazılınca E4 hücresine her durumda bunu ilave edecek

2. durumda (Move) ilk şart
B4 ve altında hücreye bir ifade yazılınca daha önce bu ifade yazılmamışsa E4 hücresine bunu ilave edecek

2. durumda (Move) ikinci şart
B4 ve altında hücreye bir ifade yazılınca daha önce bu ifade yazılmışsa E4 hücresine bunu ilave etmeyecek
ya da
B4 ve altında hücreye bir ifade yazılınca daha önce bu ifade yazılmışsa E4 hücresinden eskisini silip sona ilave edecek

Bence ben yanlış anlıyorum.
Siz bunların yerine bir kaç örnek tablo oluşturursanız daha sağlıklı olacak.

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
İlgi ve sabrınıza teşekkür ederim. Sanırım bu örnekler yeterli. Sorun olursa da makinemin başındayım.
Saygılarımla

 

[ÖmerFaruk]

Anladığım haliyle aşağıdadır.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B6:B9")) Is Nothing Then
    On Error Resume Next
    Application.EnableEvents = False
    Range("E4") = WorksheetFunction.TextJoin(" ", 1, Range("E4"), Target)
    Application.EnableEvents = True
    On Error GoTo 0
End If
If Not Intersect(Target, Range("B14:B19")) Is Nothing Then
    On Error Resume Next
    Application.EnableEvents = False
    Range("E14") = "a b c d e"
    For k = 14 To 19
    Range("E14") = Replace(Range("E14"), Range("B" & k), "")
    Next k
    Range("E14") = Trim(Range("E14"))
    Application.EnableEvents = True
    On Error GoTo 0
End If
End Sub

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
İlginiz için tekrar teşekkür ederim. Öncekilerde tam anlatamamışım. Sayfa1 copy için Sayfa2 move için. (makrolar ayrı dosyalar için)
Saygılarımla

 

[ÖmerFaruk]

Tevfik bey
Ben sizi biraz zorlayayım. Sizin rahatlıkla yapabileceğinize inanıyorum
Kod içinde iki tane IF Bloğu var.
Birinci bloğu sayfa1 in Worksheet_Change olayında
İkinci bloğu sayfa2 in Worksheet_Change olayında
yazacaksınız
Kodların içindeki hücre başvurularını da kendinize göre ayarlayabilirsiniz.

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
Ornek2.xlsm dediğiniz gibi hazırlandı. Ama enter tuşu hiç bir noktayı tetiklemedi.
Saygılarımla

 

[ÖmerFaruk]

Gönderdiğiniz dosyada;

Sayfa1 deki kodlarınız aşağıda.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B6:B9")) Is Nothing Then
        On Error Resume Next
        Application.EnableEvents = False
            Range("E4") = WorksheetFunction.TextJoin(" ", 1, Range("E4"), Target)
        Application.EnableEvents = True
        On Error GoTo 0
    End If
End Sub

B6:B9 hücrelerine bir şey yazınca E4 hücresinde gerekli işlem gerçekleşiyor. Olmayan neresi? Eğer E6 da yapsın istiyorsanız E4 yazan kısımları E6 yapabilirsiniz. Kaldı ki şöyle demiştim. "Kodların içindeki hücre başvurularını da kendinize göre ayarlayabilirsiniz."



Sayfa2 de kodlarınız aşağıda

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B6:B11")) Is Nothing Then
        On Error Resume Next
        Application.EnableEvents = False
        'Range("E6") = "a b c d e"
            For k = 6 To 11
                Range("E6") = Replace(Range("E6"), Range("B" & k), "")
            Next k
        Range("E6") = Trim(Range("E6"))
        Application.EnableEvents = True
        On Error GoTo 0
    End If
End Sub

'Range("E6") = "a b c d e" satırının başına tırnak koymuşsunuz. Tırnak işaretini kaldırınca kodlar çalışır.

Bu arada ben anlayabildiğim şekilde sonuç ürettim. Özellikle sayfa2 için.
B6:B11 aralığına girdiğiniz a-b-c-d-e-f değerlerinden herhangi biri varsa E6 hücresinde o değer yer almıyor.
Siz farklı bir şey mi istiyorsunuz?

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
Burada E4, E6 ve B sütunundaki harfler temsili (sadece örnek için). B sütunundaki harfler ve/veya heceler, kelimeler zaten geliyor. Benim derdim
Sayfa1 de; cursor B6:B9 arasında hangi hücrede enter basarsa o hücredekini E4 e götürecek, o hücredeki de yerinde kalacak. Tekrar seçilebilir.
Sayfa2 de; cursor B6:B11 arasında hangi hücrede enter basarsa o hücredekini E6 ya götürecek, o hücredeki silinecek. Tekrar seçilemez.
Kusuruma bakmayın lütfen, tam izah edememişim.
Saygılarımla

 

[ÖmerFaruk]

Sayfa1 de; cursor B6:B9 arasında hangi hücrede enter basarsa o hücredekini E4 e götürecek, o hücredeki de yerinde kalacak. Tekrar seçilebilir.
Ben de bunu diyorum. Yazdığınızdan farklı bir işlem yok. Aynen bunu yapıyor.

Sayfa2 de aşağıdaki kodu kullanabilirsiniz.
Enter basmak demek, hücrede bir şey yazdınız diye anlıyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B6:B11")) Is Nothing Then
        On Error Resume Next
        Application.EnableEvents = False
        Range("E6") = Target
        Application.EnableEvents = True
        On Error GoTo 0
    End If
End Sub

 

[Tevfik_Kursun]

Merhaba Sayın Hocam,,

Sayfa2 de aşağıdaki kodu kullanabilirsiniz.
Enter basmak demek, hücrede bir şey yazdınız diye anlıyorum.

Yeni bir şey yazmıyoruz. B6:B9 arasında kursor dolaşırken enter bastığı hücredeki ifadeyi E4 e götürecek. Yeni bir şey yazarak değil.
Saygılarımla

 

[Tevfik_Kursun]

Merhaba,
Burada çift tıklama ile çözdüm. Mümkünse ENTER ile çözülsün isterim. B sütununda dolu hücrelerde çift tıklanınca E6 ya götürüyor.
Saygılarımla

 

[ÖmerFaruk]

Çalışma Kitabı (ThisWorkBook) kodlarına aşağıdakini yapıştırın

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnKey " "
End Sub
Sub Workbook_Open()
    Application.OnKey "~", "Makrom"
End Sub

Kod sayfanıza boş bir modul ekleyin ve aşağıdaki kodları yapıştırın

Sub Makrom()
    If ActiveWorkbook.Name = ThisWorkbook.Name Then
    If ActiveSheet.Name = "Sayfa1" And ActiveCell.Column = 2 And ActiveCell.Row >= 6 And ActiveCell.Row <= 9 Then
        Application.EnableEvents = False
        Range("E6") = WorksheetFunction.TextJoin(" ", 1, Range("E6"), ActiveCell)
        Application.EnableEvents = True
    End If
    If ActiveSheet.Name = "Sayfa2" And ActiveCell.Column = 2 And ActiveCell.Row >= 6 And ActiveCell.Row <= 11 Then
        Application.EnableEvents = False
        Range("E6") = WorksheetFunction.TextJoin(" ", 1, Range("E6"), ActiveCell)
        ActiveCell = ""
        Application.EnableEvents = True
    End If
    End If
    ActiveCell.Offset(1, 0).Select
End Sub

Çalışma kitabınızı kaydedin ve kapatın. Tekrar açın.

Orjinal dosyanızda, gerekiyorsa Sayfa1 ve Sayfa2 isimlerini ve hücre başvurularınızı, satır sütün sayılarınızı değiştirebilirsiniz

 

[Tevfik_Kursun]

Günaydın ÖmerFaruk Hocam,
Sizi çok yormuşum, ilginize çok teşekkür ederim. Sanırım bir önlem daha almak lazım, gelip aynı satırda duruyor.
Saygılarımla

 

[ÖmerFaruk]

İlk sorunuzda aynı sayfada, ikincide ayni kitaptaydı. Şimdi farklı kitaplarda mı olacak bu kodlar. Ve kitapları beraber mi açacaksınız?
Gönderdiğim dosya kendi başına işinizi görmüyor mu?

 

[Tevfik_Kursun]

Merhaba ÖmerFaruk Hocam,
Bende her iki halde de çalışmadı, resimlerdeki hatayı verdi. Nerede hata yapmış olabilirim diye ayırdım. (Zaten ayrı ayrı öğrenci önüne konacaklar.)
On Error Resume Next satırını eklediğinde move dosyasında silmeyi gördüm. (bütün çalıştığı bu oldu)
Saygılarımla

 

[ÖmerFaruk]

Size gönderdiğim önceki kodların bulunduğu dosya ektedir. Bu dosya üzerinden bakın lütfen.

 

[Tevfik_Kursun]

Tekrar Merhaba,
Sayın Hocam, excelinizde eklenti mi var? Gönderdiğinizi indirip, açıp entere bastım. Sonuçlar resimlerde.
Saygılarımla