• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki Kritere Göre Uyarı Mesajı Vermesini Sağlamak

A

Allback

Katılım
21 Eylül 2011
Mesajlar
115
Excel Vers. ve Dili
Office 365 - İngilizce
Merhaba,

Excelde takip ettiğim bir sayaç tablom var.
Bu tabloya göre "A" sütunundaki değer 4820 veya 4821 ise ve "B" sütunundaki değer büyük eşit 900 ise aşağıdaki gibi bir uyarı mesajı verebilir mi?


"PPC03R PRESİNİN TEMİZLİK ZAMANI GELMİŞTİR."
"PPC03L PRESİNİN TEMİZLİK ZAMANI GELMİŞTİR."

Not: "PPC03R" ve "PPC03L" bilgilerini koşulun sağlandığı aynı satırdaki "C" sütunundan alacak...
 

Ekli dosyalar

Allback' Alıntı:
Merhaba,

Excelde takip ettiğim bir sayaç tablom var.
Bu tabloya göre "A" sütunundaki değer 4820 veya 4821 ise ve "B" sütunundaki değer büyük eşit 900 ise aşağıdaki gibi bir uyarı mesajı verebilir mi?


"PPC03R PRESİNİN TEMİZLİK ZAMANI GELMİŞTİR."
"PPC03L PRESİNİN TEMİZLİK ZAMANI GELMİŞTİR."

Not: "PPC03R" ve "PPC03L" bilgilerini koşulun sağlandığı aynı satırdaki "C" sütunundan alacak...
Genişletmek için tıkla ...
Merhaba Dosyanız ektedir deneyiniz.
 

Ekli dosyalar

Çok teşekkürler, ben de uğraşırken aşağıdaki gibi bir çözüm buldum. Sizinkine çok benziyor zaten.
Tekrar teşekkürler

Kod: 
Sub KOD()
Application.ScreenUpdating = False

For Each a In Range("H1:" & [H65536].End(3).Address(0, 0))
If a.Offset(0, 0) = "4820" And a.Offset(0, 5) >= 900 Then
msj = msj & a.Offset(0, 3) & ", "
End If

If a.Offset(0, 0) = "4821" And a.Offset(0, 5) >= 900 Then
msj = msj & a.Offset(0, 3) & ", "
End If

Next

Application.ScreenUpdating = True
MsgBox "DİKKAT! " & msj & " PRESLERİN TEMİZLİK ZAMANI GELMİŞTİR."

End Sub
 
Rica ederim , sorununuz çözüldü ise sıkıntı yok ,iyi çalışmalar.
 
Tekrar merhaba,

Msgbox ile ilgili bir sorunum var.
Kriterlere uyan 4 farklı sonucum var. Her bir sonuç için ayrı ayrı mesaj kutusu yerine hepsini tek seferde göstermek istiyorum. (örneği açtığınızda çıkan 4. uyarı mesajındaki gibi)

Koşulu ayrı tanımlayıp, mesaj kutusunu en alta ekleyince hepsini tek seferde gösteriyor ama bu sefer de kritere uyan herhangi bir sonuç olmadığında da en alta eklediğim mesaj kutusu çıkıyor.

Bu sorunu nasıl çözebilirim.
 

Ekli dosyalar

Makroda her a için uyarı mesajı çıkmasını sağlamışsınız. Tüm satırların kontrolü bittikten sonra messaj çıkmasını istiyorsanız, sayın @Allblack'in kodlarında olduğu gibi mesajla/msgboxla ilgili satırı Next satırından sonraya almalısınız:

PHP: 
Sub KOD()
Application.ScreenUpdating = False

For Each a In Range("B1:" & [B65536].End(3).Address(0, 0))
    If a.Offset(0, 0) = "4820" And a.Offset(0, 5) >= 900 Then
        msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
    End If
    If a.Offset(0, 0) = "4821" And a.Offset(0, 5) >= 900 Then
        msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
    End If
Next
    MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
Application.ScreenUpdating = True

End Sub
 
Kodu şu şekilde kısaltabilirsiniz:

PHP: 
Sub KOD()
Application.ScreenUpdating = False

For Each a In Range("B1:" & [B65536].End(3).Address(0, 0))
    If a = "4820" Or a = "4821" And a.Offset(0, 5) >= 900 Then
        msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
    End If
Next
    MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
Application.ScreenUpdating = True

End Sub
 
YUSUF44' Alıntı:
Kodu şu şekilde kısaltabilirsiniz:

PHP: 
Sub KOD()
Application.ScreenUpdating = False

For Each a In Range("B1:" & [B65536].End(3).Address(0, 0))
    If a = "4820" Or a = "4821" And a.Offset(0, 5) >= 900 Then
        msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
    End If
Next
    MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...

Yusuf Bey merhaba,

Öncelikle yardımcı olmaya çalıştığınız için teşekkürler.
İlk verdiğiniz kod örneğindeki gibi yapınca benim dediğim gibi oluyor. Hepsi tek mesajda çıkıyor ama koşulu sağlamadığı zaman da "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR. KALIPLARI TEMİZLİĞE ALIN." uyarı mesajı çıkmaya devam ediyor.

İkinci örnekte koşulu sağlamasa bile koşulu sağlamış gibi uyarı veriyor...
 
Alternatif olarak
Kod: 
Sub Emr()
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, "B") = 4820 Or Cells(i, "B") = 4821 Then
        If Cells(i, "G") >= 900 Then
            msj = msj & Cells(i, "E") & " PRESİNDE ÇALIŞAN " & Cells(i, "A") & vbNewLine & ""
        End If
    End If
Next
Application.ScreenUpdating = True
If msj <> "" Then MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
End Sub
 
Aşağıdaki gibi deneyin:

Kod: 
Sub KOD()
Application.ScreenUpdating = False
son = Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIfs(Range("B1:B" & son), "4820", Range("G1:G" & son), ">=900") = 0 And _
    WorksheetFunction.CountIfs(Range("B1:B" & son), "4821", Range("G1:G" & son), ">=900") = 0 Then
    MsgBox "Ömrü 900'ü geçen kalıp bulunmamaktadır. " & Chr(10) & "İyi çalışmalar.", vbInformation, "HCS Temizlik Uyarısı"
    GoTo 10
Else
    For Each a In Range("B1:" & [B65536].End(3).Address(0, 0))
        If a = "4820" And a.Offset(0, 5) >= 900 Or a = "4821" And a.Offset(0, 5) >= 900 Then
            msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
        End If
    Next
    MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
End If
10:
Application.ScreenUpdating = True

End Sub
 
EmrExcel16' Alıntı:
Alternatif olarak
Kod: 
Sub Emr()
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, "B") = 4820 Or Cells(i, "B") = 4821 Then
        If Cells(i, "G") >= 900 Then
            msj = msj & Cells(i, "E") & " PRESİNDE ÇALIŞAN " & Cells(i, "A") & vbNewLine & ""
        End If
    End If
Next
Application.ScreenUpdating = True
If msj <> "" Then MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
End Sub
Genişletmek için tıkla ...

Teşekkürler, bu şekilde yapınca oldu...
 
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin:

Kod: 
Sub KOD()
Application.ScreenUpdating = False
son = Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIfs(Range("B1:B" & son), "4820", Range("G1:G" & son), ">=900") = 0 And _
    WorksheetFunction.CountIfs(Range("B1:B" & son), "4821", Range("G1:G" & son), ">=900") = 0 Then
    MsgBox "Ömrü 900'ü geçen kalıp bulunmamaktadır. " & Chr(10) & "İyi çalışmalar.", vbInformation, "HCS Temizlik Uyarısı"
    GoTo 10
Else
    For Each a In Range("B1:" & [B65536].End(3).Address(0, 0))
        If a = "4820" And a.Offset(0, 5) >= 900 Or a = "4821" And a.Offset(0, 5) >= 900 Then
            msj = msj & a.Offset(0, 3) & " PRESİNDE ÇALIŞAN " & a.Offset(0, -1) & vbNewLine & ""
        End If
    Next
    MsgBox msj & "" & vbNewLine & "KALIPLARININ ÖMRÜ 900'Ü GEÇMİŞTİR." & vbNewLine & "KALIPLARI TEMİZLİĞE ALIN.", vbCritical, "HCS Temizlik Uyarısı"
End If
10:
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...

Bu şekilde de çok güzel oldu, her ikinizin de ellerine sağlık...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst