Yan Hücredeki Seçime Göre aktif hücreye bilgi yazılması

[toybuklu]

Merhaba Arkadaşlar,

bir sorum var Excel de örneğin A1 Hücresinde listbox ile belli bilgiler default seçtiriyorum.

Örnek; List Boxda Hastalık, Doktor Kontrolü, Proje yazıyor.

Ben A1 Hücresindeki listboxımdan Proje harici bir seçim yaparsam A1 hücresinde yazan bilgiyi B1 hücresine yazsın,
Ancak ben listbox dan Proje seçersem bir input Box açılsın ve proje adının 49 karakteri geçmeyecek şekilde inputboxa girilmesini istesin.

İnputboxa proje adı girildiğinde bu bilgiyi B1 hücresine yazsın.

bu kontrol ve işlemler her yeni satırda devam etsin yani aktif hücrede.

Olay A ve B kolonlarında gerçekleşecek Listbox seçimleri A Kolonunda veri girişi B kolonunda olacak.

Bu konuda bana yardımcı olabilirseniz çok memnun olurum.
Şimdiden ellerinize sağlık diyor teşekkür ediyorum

Saygılarımla

 

[turist]

Sayın @toybuklu
Sorunuzu kendi hazırladığınız bir "örnek" excel dosyası ekleyerek sorarsanız, daha hızlı ve doğru cevaplar bulabilirsiniz.
Örnek excel dosyası ekleme hakkında bilgi edinmek isterseniz:
https://www.excel.web.tr/threads/soru-ile-ilgili-oernek-excel-dosyasi-ekleme.174755/ bakınız

 

[toybuklu]

https://drive.google.com/file/d/1MiNrM5XEZ8bWxAu99CPL_uvf2ZvCwsel/view?usp=drivesdk

Buraya yükledim umarım açılır.yukarda metine göre düşünülebilir.

 

[toybuklu]

B kolonundaki hücrelere sadece macro giriş yapabilecek kullanıcı giriş yapamayacak. amacım b kolonunun karışmasını ve kullnıcıların B kolonunu çorba yapmalarını engellemek.

 

[Korhan Ayhan]

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = "Proje" Then
10      Proje = Application.InputBox("Lütfen proje açıklaması giriniz." & Chr(10) & _
                "En çok 49 karakter uzunluğunda açıklama yazınız.", "AÇIKLAMA")
        If Proje = "" Or Proje = False Then GoTo 10
        If Len(Proje) > 49 Then
            MsgBox "Lütfen 49 karakter uzunluğunda açıklama giriniz.", vbExclamation
            GoTo 10
            Exit Sub
        Else
            Target.Next.Value = Proje
        End If
    Else
        Target.Next.Value = Target.Value
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 2 Then
        MsgBox "AÇIKLAMA sütununa elle veri girişi yapmayınız!", vbCritical
        If Selection.Cells.Count = Rows.Count Then
            Selection.Previous.EntireColumn.Select
        Else
            Selection.Previous.Select
        End If
    End If
End Sub

 

[toybuklu]

Çok teşekkür ederim Korhan hocam tam istediğim gibi ancak 2. kod alanında B kolonu yada B kolonunda ki hücreleri seçemiyor ya bu sıkınıtı çünkü içine yazılan değeri hücreyi seçemediğimiz için alıp kopyalama vs gibi durumları yapamayacağız.

Kullanıcı kolonu yada hücreyi seçebilsin ancak değiştiremesin yada manuel elle giriş yapamasın şeklinde olabilirmi?

Saygılarımla

 

[Korhan Ayhan]

Bu durumda kod aşağıdaki gibi değiştirip deneyiniz.

Dim Eski_Veri As Variant, Onay As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
        If Target.Cells.Count > 1 Then Exit Sub
        If Target.Value = "Proje" Or Target.Value = "Aynı Güne 1'den Fazla Giriş" Then
10          Onay = False
            Proje = Application.InputBox("Lütfen proje açıklaması giriniz." & Chr(10) & _
                    "En çok 49 karakter uzunluğunda açıklama yazınız.", "AÇIKLAMA")
            If Proje = "" Or Proje = False Then GoTo 10
            If Len(Proje) > 49 Then
                MsgBox "Lütfen 49 karakter uzunluğunda açıklama giriniz.", vbExclamation
                GoTo 10
                Exit Sub
            Else
                Onay = True
                Target.Next.Value = Proje
            End If
        Else
            Onay = True
            Target.Next.Value = Target.Value
        End If
    End If

    If Not Intersect(Target, Range("B2:B" & Rows.Count)) Is Nothing Then
        If Onay = False Then
            If Target.Value <> Eski_Veri Then
                MsgBox "AÇIKLAMA sütununa elle veri girişi yapmayınız!", vbCritical
                Target.Value = Eski_Veri
            End If
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Onay = False
    Eski_Veri = Target.Value
End Sub

 

[toybuklu]

Korhan Hocam birde Proje seçimine ek olarak "Aynı Güne 1'den Fazla Giriş" seçeneği seçilirse de aynı süreç işlesin ben "Proje" Or "Aynı Güne 1'den Fazla İş Giriş" olarak yaptım ama Type mismacth hatası veriyor

 

[toybuklu]

Verdiğiniz Kodu kullandığımda a kolonundan yeni bir seçimde yapsam AÇIKLAMA sütununa elle veri girişi yapmayınız! uyarası veriyor

 

[Korhan Ayhan]

#7 nolu mesajımdaki kodu güncelledim. Tekrar deneyiniz.

 

[toybuklu]

Elinize kolunuza aklınıza sağlık hocam tşk ederim.