Satırda fiyat hücresi boş ise

Tarikkk_

Altın Üye
Katılım
5 Ocak 2020
Mesajlar
349
Excel Vers. ve Dili
Excel 2019
merhabalar örnek dosyamda , aktif satırda ad soyad işlem açıklama boş değil ama fiyat boş ve farklı bir satıra geçtiğimizde uyarı mesajı versin ve boş olan fiyat hücresine select etsin istiyorum. yardımlarınız için şimdiden çok teşekkür ederim.
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
21,188
Excel Vers. ve Dili
2016-Türkçe
Merhaba,

Sayfanın kod bölümüne ekleyip deneyiniz.
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim son As Long, i As Long, s As Byte
    son = Range("D4:H" & Rows.Count).Find("*", , , , xlByRows, xlPrevious).Row
    For i = 5 To son
        s = WorksheetFunction.CountA(Cells(i, "D").Resize(1, 4))
        If s = 4 And Cells(i, "H") = "" Then
            Cells(i, "H").Select
            Exit Sub
        End If
    Next i
End Sub
 

Tarikkk_

Altın Üye
Katılım
5 Ocak 2020
Mesajlar
349
Excel Vers. ve Dili
Excel 2019
Merhaba,

Sayfanın kod bölümüne ekleyip deneyiniz.
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim son As Long, i As Long, s As Byte
    son = Range("D4:H" & Rows.Count).Find("*", , , , xlByRows, xlPrevious).Row
    For i = 5 To son
        s = WorksheetFunction.CountA(Cells(i, "D").Resize(1, 4))
        If s = 4 And Cells(i, "H") = "" Then
            Cells(i, "H").Select
            Exit Sub
        End If
    Next i
End Sub
hocam çok teşekkür ederim tam olarak istediğim şey fakat biraz anlayacağım dile çevirdim bazı şeyleri mesajda ekledim mesajdan sonra exit sub koydum ama nedense 2 kez mesajı gösteriyor sebebini anlayamadım kodları paylaşıyorum. yardımlarınızı bekliyorum. teşekkürler


Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim son As Long, i As Long, s As Byte
    
    SonSatır = Sheets("Sayfa1").Cells(Rows.Count, "D").End(3).Row
    
    For i = 5 To SonSatır
    
    If Cells(i, "D") <> "" And Cells(i, "E") <> "" And Cells(i, "F") <> "" And Cells(i, "G") <> "" Then
        If Cells(i, "H") = "" Then
                 Cells(i, "H").Select
                    MsgBox "Fiyat Boş Bırakmayınız"
                Exit Sub
            End If
        End If
     Next i
End Sub
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
10,528
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Kodları SelectionChange olayına yazmışsınız, yani hücre seçilince çalışacak şekilde ayarlamışsınız ve kod içinde de hücre seçme olayı var. Kod hücreyi seçince kodlar baştan tekrar devreye giriyor bu nedenle.

Eğer amacınız hücre seçiminde kodların çalışmasıysa Cells(i,"H").select satırından önce

ApplicationEnableEvents = False

satırını ve sonra da (yani msgbox satırından önce)

ApplicationEnableEvents = True

Satırını ekleyip deneyin.
 

Tarikkk_

Altın Üye
Katılım
5 Ocak 2020
Mesajlar
349
Excel Vers. ve Dili
Excel 2019
Kodları SelectionChange olayına yazmışsınız, yani hücre seçilince çalışacak şekilde ayarlamışsınız ve kod içinde de hücre seçme olayı var. Kod hücreyi seçince kodlar baştan tekrar devreye giriyor bu nedenle.

Eğer amacınız hücre seçiminde kodların çalışmasıysa Cells(i,"H").select satırından önce

ApplicationEnableEvents = False

satırını ve sonra da (yani msgbox satırından önce)

ApplicationEnableEvents = True

Satırını ekleyip deneyin.

bu şekilde ekleyince çalışmadı yine 2 kez uyarımesajı veriyor

Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim son As Long, i As Long, s As Byte
    
    SonSatır = Sheets("Sayfa1").Cells(Rows.Count, "D").End(3).Row
    
    For i = 5 To SonSatır
    
    If Cells(i, "D") <> "" And Cells(i, "E") <> "" And Cells(i, "F") <> "" And Cells(i, "G") <> "" Then
        If Cells(i, "H") = "" Then
        
             ApplicationEnableEvents = False
            Cells(i, "H").Select
            ApplicationEnableEvents = True
            MsgBox "Fiyat Boş Bırakmayınız"
          
         End If
       End If
        Next i
 
    End Sub
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
10,528
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Exit sub nerede?
 
Üst