Belli aralıktaki hücrelerde EKSİK VAR! yazısının yanıp sönmesi

schadow · 7 Kasım 2015

Arkadaşlar şunu kulladım fakat o sadece b1 hücresinde işe yarıyor.

Bunu B1-B300 arasında nasıl çalıştırıcaz?

VisulBasic
=========
Option Explicit
Public CellCheck As Boolean
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Range("B1") >= "EKSİK VAR!" And CellCheck = False Then
Call StartBlink
CellCheck = True
ElseIf Range("B1") <> "EKSİK VAR!" And CellCheck = True Then
Call StopBlink
CellCheck = False
End If
End Sub
=======
MODUL
====
Option Explicit
Public RunWhen As Double
Sub StartBlink()
If Range("B1").Interior.ColorIndex = 3 Then
Range("B1").Interior.ColorIndex = 6
Else
Range("B1").Interior.ColorIndex = 3
End If
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "StartBlink", , True
End Sub
Sub StopBlink()
Range("B1").Interior.ColorIndex = xlAutomatic
Application.OnTime RunWhen, "StartBlink", , False
End Sub

PLİNT · 7 Kasım 2015

Merhaba
Kodlarınızın tümünü aşağıdakilerle değiştirerek; deneyin.

Sayfa kod:

Kod:

Option Explicit
Public CellCheck As Boolean
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim c As Range
Range("b1:b300").Interior.ColorIndex = xlNone
With Range("b1:b300")
    Set c = .Find("EKSİK VAR!", LookIn:=xlValues)
    If Not c Is Nothing And CellCheck = False Then
    Call StartBlink
    CellCheck = True
    ElseIf c Is Nothing And CellCheck = True Then
    Call StopBlink
    CellCheck = False
    End If
End With
End Sub

Modül kod:

Kod:

Option Explicit
Public RunWhen As Double
Sub StartBlink()
With ActiveSheet.Range("b1:b300")
Dim c, f
    Set c = .Find("EKSİK VAR!")
    If Not c Is Nothing Then
        f = c.Address
        Do
If Range("B" & c.Row).Interior.ColorIndex = 3 Then
Range("B" & c.Row).Interior.ColorIndex = 6
Else
Range("B" & c.Row).Interior.ColorIndex = 3
End If
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "StartBlink", , True
End Sub
'............................................
Sub StopBlink()
Range("B1:b300").Interior.ColorIndex = xlNone
Application.OnTime RunWhen, "StartBlink", , False
End Sub

schadow · 7 Kasım 2015

Hocam yapmaya çalıştım fakat olmadı.
http://s6.dosya.tc/server3/vbc6c5/Siparis_Icmal_Formu.xlsx.html

Cümle formül ile geldiğinden olmuyor

ÖmerBey · 7 Kasım 2015

PLİNT' Alıntı:

Merhaba
Kodlarınızın tümünü aşağıdakilerle değiştirerek; deneyin.

Sayfa kod:

Kod:

Option Explicit
Public CellCheck As Boolean
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim c As Range
Range("b1:b300").Interior.ColorIndex = xlNone
With Range("[COLOR="Red"]b1:b300[/COLOR]")
    Set c = .Find("EKSİK VAR!", LookIn:=xlValues)
    If Not c Is Nothing And CellCheck = False Then
    Call StartBlink
    CellCheck = True
    ElseIf c Is Nothing And CellCheck = True Then
    Call StopBlink
    CellCheck = False
    End If
End With
End Sub

Modül kod:

Kod:

Option Explicit
Public RunWhen As Double
Sub StartBlink()
With ActiveSheet.Range("[COLOR="red"]b1:b300[/COLOR]")
Dim c, f
    Set c = .Find("EKSİK VAR!")
    If Not c Is Nothing Then
        f = c.Address
        Do
If Range("B" & c.Row).Interior.ColorIndex = 3 Then
Range("B" & c.Row).Interior.ColorIndex = 6
Else
Range("B" & c.Row).Interior.ColorIndex = 3
End If
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "StartBlink", , True
End Sub
'............................................
Sub StopBlink()
Range("B1:b300").Interior.ColorIndex = xlNone
Application.OnTime RunWhen, "StartBlink", , False
End Sub

Merhaba,
Dosyanıza uygun olması için PLİNT'in paylaştığı kodlardaki kırmızı ile göstediğim kısımları F1:F300 olarak değiştiriniz.
İyi çalışmalar...

PLİNT · 7 Kasım 2015

schadow' Alıntı:
Hocam yapmaya çalıştım fakat olmadı.

Cümle formül ile geldiğinden olmuyor

Merhaba
Dosyanızda olmama sebebi formüller değil,"f" sütununu ilgilendiren koşullu biçimlendirme. Koşullu biçimlendirme kaldırılmalı; zaten yukarıdaki
kodlar sadece veri girişine göre olduğu için,sizin dosyanıza uygun değil.

Ek dosyadaki gibi düzenleyin.
http://s6.dosya.tc/server3/t7q1nd/icmal.zip.html

"MALZEME DURUMU" Kod sayfasına:

Kod:

Private Sub Worksheet_Activate()
If WorksheetFunction.CountIf(Range("f1:f350"), "EKSİK VAR!") > 0 Then Run ("renk")
End Sub
'.....................................................
Private Sub Worksheet_Change(ByVal Target As Range)
Run ("dur")
Range("f1:f350").Interior.ColorIndex = xlNone
If WorksheetFunction.CountIf(Range("f1:f350"), "EKSİK VAR!") > 0 Then Run ("renk")
End Sub
'......................................................
Private Sub Worksheet_Deactivate()
Run ("dur")
Range("f1:f350").Interior.ColorIndex = xlNone
End Sub

MODÜL kod sayfasına:

Kod:

Private g
Sub renk()
Dim s As Worksheet
If Application.ActiveWorkbook.Name <> ThisWorkbook.Name Then
g = Empty
Exit Sub
End If
Set s = Sheets("MALZEME DURUMU")
If ActiveSheet.Name <> "MALZEME DURUMU" Then
Call dur: Exit Sub: End If
n = WorksheetFunction.CountIf(s.Range("f1:f350"), "EKSİK VAR!")
If n = 0 Then: Call dur: Exit Sub
With s.Range("f1:f350")
Set c = .Find("EKSİK VAR!", LookIn:=xlValues)
If Not c Is Nothing Then
        f = c.Address
        Do
If s.Range("f" & c.Row).Interior.ColorIndex = 3 Then
Range("f" & c.Row).Interior.ColorIndex = 6
Else
Range("f" & c.Row).Interior.ColorIndex = 3
End If
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
   Loop While Not c Is Nothing And c.Address <> f
   Else
   If g <> Empty Then Call dur: Exit Sub
   End If
End With
g = Now + TimeSerial(0, 0, 1)
Application.OnTime g, "renk", , True
End Sub
Sub dur()
If g <> Empty Then
Application.OnTime g, "renk", , False
g = Empty
End If
End Sub

BuÇalışmaKitabı (Thisworkbook) KOD SAYFASINA

Kod:

Private Sub Workbook_Activate()
Set s = Worksheets("MALZEME DURUMU")
s.Unprotect "12345"
s.Cells.Locked = True
If ActiveSheet.Name = "MALZEME DURUMU" And _
WorksheetFunction.CountIf(Range("f1:f350"), "EKSİK VAR!") > 0 Then
Range("f1:f350").Interior.ColorIndex = xlNone
Run ("renk")
End If
s.Protect "12345", , , AllowFormattingCells:=True, AllowInsertingRows:=True
s.EnableSelection = xlNoRestrictions
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ActiveSheet.Name = "MALZEME DURUMU" Then Call dur
End Sub

schadow · 8 Kasım 2015

Teşekkürler Hocam Oldu.
Allah Razı Olsun

Peki hocam birşey sorcam. Veri girişi yapıyorum ve kaydedip kapatıyorum.
Dosyayı açtığımda bazen makro çalışmıyor ve kodları silip yeniden girmem gerekiyor. Bunun sebebi nedir?

Birde dosyaya koruma koyduğumda "Range("f" & c.Row).Interior.ColorIndex = 3" hatası alıyorum onu nasıl düzeltirim?
2. bir excel dosyası ile çalışınca hata veriyor onu nasıl düzeltirim?

PLİNT · 8 Kasım 2015

schadow' Alıntı:
Veri girişi yapıyorum ve kaydedip kapatıyorum.
Dosyayı açtığımda bazen makro çalışmıyor ve kodları silip yeniden girmem gerekiyor. Bunun sebebi nedir?

Etkileyen kodlar olabilir.

schadow' Alıntı:
Birde dosyaya koruma koyduğumda "Range("f" & c.Row).Interior.ColorIndex = 3" hatası alıyorum onu nasıl düzeltirim?
2. bir excel dosyası ile çalışınca hata veriyor onu nasıl düzeltirim?

Yukarıdaki (5.mesajda) değişen kodlarda bu sorunlar için eklemeler yapmaya çalıştım.
(Sayfa Korumalı iken satır ekleyebilirsiniz.)
"Sub auto_open" bölümü Modülden; "Thisworkbook" kod sayfasına eklendi
Kodların içinde görebileceğiniz gibi; "MALZEME DURUMU" Sayfası koruma parolası "12345"
Değişen dosya ekte
http://s6.dosya.tc/server3/t7q1nd/icmal.zip.html

schadow · 9 Kasım 2015

PLİNT' Alıntı:
Etkileyen kodlar olabilir.

Yukarıdaki (5.mesajda) değişen kodlarda bu sorunlar için eklemeler yapmaya çalıştım.
(Sayfa Korumalı iken satır ekleyebilirsiniz.)
"Sub auto_open" bölümü Modülden; "Thisworkbook" kod sayfasına eklendi
Kodların içinde görebileceğiniz gibi; "MALZEME DURUMU" Sayfası koruma parolası "12345"
Değişen dosya ekte
http://s6.dosya.tc/server3/t7q1nd/icmal.zip.html

Hocam Teşekkürler oldu fakat B-C-D-E ve H-O arasına,P-S arasına,V-Y arasına AB-AE arasına, AH-AM arasına veri girişi olacağından kilitten dolayı girilemiyor.

PLİNT · 9 Kasım 2015

schadow' Alıntı:
Hocam Teşekkürler oldu fakat B-C-D-E ve H-O arasına,P-S arasına,V-Y arasına AB-AE arasına, AH-AM arasına veri girişi olacağından kilitten dolayı girilemiyor.

İlgili kod sayfasına aşağıdaki kırmızı bölümü ekleyin,dosyayı kaydedip açın.

Kod:

 Private Sub Workbook_Activate()
Set s = Worksheets("MALZEME DURUMU")
s.Unprotect "br"
s.Cells.Locked = True
[COLOR="Red"]s.Range("B6:E10000,H6:S10000,V6:Y10000,AB6:AE10000,AH6:AM10000").Locked = False[/COLOR]

 If ActiveSheet.Name = "MALZEME DURUMU" And _
WorksheetFunction.CountIf(Range("f1:f350"), "SİPARİŞ GELMEDİ") > 0 Then

schadow · 9 Kasım 2015

PLİNT' Alıntı:

İlgili kod sayfasına aşağıdaki kırmızı bölümü ekleyin,dosyayı kaydedip açın.

Kod:

 Private Sub Workbook_Activate()
Set s = Worksheets("MALZEME DURUMU")
s.Unprotect "br"
s.Cells.Locked = True
[COLOR="Red"]s.Range("B6:E10000,H6:S10000,V6:Y10000,AB6:AE10000,AH6:AM10000").Locked = False[/COLOR]

 If ActiveSheet.Name = "MALZEME DURUMU" And _
WorksheetFunction.CountIf(Range("f1:f350"), "SİPARİŞ GELMEDİ") > 0 Then

Teşekkürler hocam sayende çok güzel bir tablo oldu.

schadow · 10 Kasım 2015

http://s6.dosya.tc/server4/u976bq/GUNCEL_SIPARIS_BILGILERI.rar.html

Hocam f350 yi f3500 e çıkardığımda koruma hatası veriyo ve tüm makro iptal oluyor. nasıl düzeltebilirim.
sayfa koruma:br
makro koruma:2709638

PLİNT · 10 Kasım 2015

schadow' Alıntı:
http://s6.dosya.tc/server4/u976bq/GUNCEL_SIPARIS_BILGILERI.rar.html

Hocam f350 yi f3500 e çıkardığımda koruma hatası veriyo ve tüm makro iptal oluyor. nasıl düzeltebilirim.
sayfa koruma:br
makro koruma:2709638

Merhaba
Aşağıdaki gibi deneyin.Kodları değiştiriken "MALZEME DURUMU" sayfası aktif olmasın başka sayfaya geçip; kod sayfasını açın.
Ek dosyayı incelersiniz.
http://s6.dosya.tc/server4/z3blyp/Kopya_Xl0000002.zip.html

Kod:

[COLOR="red"]son[/COLOR] = Cells(Rows.Count, "f").End(3).Row
  Range("f1:f" & [COLOR="Red"]son[/COLOR])

schadow · 10 Kasım 2015

Allah razı olsun hocam eline sağlık

schadow · 23 Aralık 2015

Hocam peki güncellediğim tabloya göre,

EKSİK VAR! a ||||||||||||||||
FAZLA VAR! a ||||||||||||||||
TAMAMLANDI ya ||||||||||||||||
yakın renkler nasıl verebilirim

http://s6.dosya.tc/server5/6i5ukh/GUNCEL_SIPARIS_BILGILERI.zip.html

PLİNT · 24 Aralık 2015

schadow' Alıntı:
Hocam peki güncellediğim tabloya göre,

EKSİK VAR! a ||||||||||||||||
FAZLA VAR! a ||||||||||||||||
TAMAMLANDI ya ||||||||||||||||
yakın renkler nasıl verebilirim

Merhaba
Önceki gibi renklendirilecek hücreler çoğalacağından arama ile değilde koşullu biçimlendirme yapılıp; kodlara bağlanırsa hızlı olacaktır, ek dosyayı inceleyiniz.
http://s3.dosya.tc/server7/tqgbu4/GUNCEL_SIPARIS_BILGILERI2.zip.html

Kod:

[COLOR="Red"]'Module 1[/COLOR]

Private g
Sub renk()
Dim s As Worksheet
If Application.ActiveWorkbook.Name <> ThisWorkbook.Name Then
g = Empty
Exit Sub
End If
Set s = Sheets("MALZEME DURUMU")
If ActiveSheet.Name <> "MALZEME DURUMU" Then
Call dur: Exit Sub: End If
son = Cells(Rows.Count, "f").End(3).Row
With Range("F6:F" & son)
If .FormatConditions(1).Interior.ColorIndex = 6 Then
.FormatConditions(1).Interior.ColorIndex = 33
.FormatConditions(2).Interior.ColorIndex = 45
.FormatConditions(3).Interior.ColorIndex = 3
.FormatConditions(4).Interior.ColorIndex = 4
Else
.FormatConditions(1).Interior.ColorIndex = 6
.FormatConditions(2).Interior.ColorIndex = 6
.FormatConditions(3).Interior.ColorIndex = 6
.FormatConditions(4).Interior.ColorIndex = 6
End If
End With
g = Now + TimeSerial(0, 0, 1)
Application.OnTime g, "renk", , True
End Sub
Sub dur()
If g <> Empty Then
Application.OnTime g, "renk", , False
g = Empty
End If
End Sub

 [COLOR="Red"]'Sayfa2 kod sayfasına:[/COLOR]

Private Sub Worksheet_Activate()
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Run ("dur")
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End Sub

Private Sub Worksheet_Deactivate()
Run ("dur")
End Sub

[COLOR="Red"]'Thisworkbook kod sayfası:[/COLOR]

Private Sub Workbook_Activate()
Set s = Worksheets("MALZEME DURUMU")
s.Unprotect "br"
s.Cells.Locked = True
s.Range("B6:E10000,H6:S10000,V6:Y10000,AB6:AE10000,AH6:AM10000").Locked = False
son = s.Cells(Rows.Count, "f").End(3).Row
If ActiveSheet.Name = "MALZEME DURUMU" Then
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End If
s.Protect "br", , , AllowFormattingCells:=True, AllowInsertingRows:=True
s.EnableSelection = xlNoRestrictions
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ActiveSheet.Name = "MALZEME DURUMU" Then Call dur
End Sub

schadow · 24 Aralık 2015

PLİNT' Alıntı:

Merhaba
Önceki gibi renklendirilecek hücreler çoğalacağından arama ile değilde koşullu biçimlendirme yapılıp; kodlara bağlanırsa hızlı olacaktır, ek dosyayı inceleyiniz.
http://s3.dosya.tc/server7/tqgbu4/GUNCEL_SIPARIS_BILGILERI2.zip.html

Kod:

[COLOR="Red"]'Module 1[/COLOR]

Private g
Sub renk()
Dim s As Worksheet
If Application.ActiveWorkbook.Name <> ThisWorkbook.Name Then
g = Empty
Exit Sub
End If
Set s = Sheets("MALZEME DURUMU")
If ActiveSheet.Name <> "MALZEME DURUMU" Then
Call dur: Exit Sub: End If
son = Cells(Rows.Count, "f").End(3).Row
With Range("F6:F" & son)
If .FormatConditions(1).Interior.ColorIndex = 6 Then
.FormatConditions(1).Interior.ColorIndex = 33
.FormatConditions(2).Interior.ColorIndex = 45
.FormatConditions(3).Interior.ColorIndex = 3
.FormatConditions(4).Interior.ColorIndex = 4
Else
.FormatConditions(1).Interior.ColorIndex = 6
.FormatConditions(2).Interior.ColorIndex = 6
.FormatConditions(3).Interior.ColorIndex = 6
.FormatConditions(4).Interior.ColorIndex = 6
End If
End With
g = Now + TimeSerial(0, 0, 1)
Application.OnTime g, "renk", , True
End Sub
Sub dur()
If g <> Empty Then
Application.OnTime g, "renk", , False
g = Empty
End If
End Sub

 [COLOR="Red"]'Sayfa2 kod sayfasına:[/COLOR]

Private Sub Worksheet_Activate()
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Run ("dur")
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End Sub

Private Sub Worksheet_Deactivate()
Run ("dur")
End Sub

[COLOR="Red"]'Thisworkbook kod sayfası:[/COLOR]

Private Sub Workbook_Activate()
Set s = Worksheets("MALZEME DURUMU")
s.Unprotect "br"
s.Cells.Locked = True
s.Range("B6:E10000,H6:S10000,V6:Y10000,AB6:AE10000,AH6:AM10000").Locked = False
son = s.Cells(Rows.Count, "f").End(3).Row
If ActiveSheet.Name = "MALZEME DURUMU" Then
son = Cells(Rows.Count, "f").End(3).Row
x = WorksheetFunction.CountIf(Range("f1:f" & son), "SİPARİŞ GELMEDİ") + WorksheetFunction.CountIf(Range("f1:f" & son), "FAZLA VAR!") _
+ WorksheetFunction.CountIf(Range("f1:f" & son), "TAMAMLANDI") + WorksheetFunction.CountIf(Range("f1:f" & son), "EKSİK VAR!")
If x > 0 Then Run ("renk")
End If
s.Protect "br", , , AllowFormattingCells:=True, AllowInsertingRows:=True
s.EnableSelection = xlNoRestrictions
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ActiveSheet.Name = "MALZEME DURUMU" Then Call dur
End Sub

Hocam çok güzel olmuş eline sağlık fakat, sadece sipariş gelmedi yanıp sönmeli yoksa çok karışıyor. Onu nasıl yaparım

PLİNT · 24 Aralık 2015

schadow' Alıntı:
Hocam çok güzel olmuş eline sağlık fakat, sadece sipariş gelmedi yanıp sönmeli yoksa çok karışıyor. Onu nasıl yaparım

Ek dosyayı inceleyin.Kodlar eksildi.
http://s6.dosya.tc/server5/k5xlte/GUNCEL_SIPARIS_BILGILERI2.zip.html
Koşullu biçimlendirmeleri ayarlayın:
Ek dosyada "sipariş gelmedi" için kırmızı (3) olarak değişti.
ötekiler için sabit kalacak; "sipariş gelmedi" kırmızı koşul rengi değişecektir.

schadow · 24 Aralık 2015

PLİNT' Alıntı:
Ek dosyayı inceleyin.Kodlar eksildi.
http://s6.dosya.tc/server5/k5xlte/GUNCEL_SIPARIS_BILGILERI2.zip.html
Koşullu biçimlendirmeleri ayarlayın:
Ek dosyada "sipariş gelmedi" için kırmızı (3) olarak değişti.
ötekiler için sabit kalacak; "sipariş gelmedi" kırmızı koşul rengi değişecektir.

Eline Sağlık Hocam Teşekkürler 10 numara oldu.

Belli aralıktaki hücrelerde EKSİK VAR! yazısının yanıp sönmesi

Destek Ekibi