Cikarma isleminin makrosu

[dennisf06]

I sütunu boyunca basit bir cikarma islemi yapiyorum. hücre degeri sifira esit degilse kosullu bicimlendirme ile kirmizi oluyor. sifira esitse hücre rengi degismiyor hücre bos görünüyor.( hücrede 0 yazmiyor. ) bu basit islemi formül+kosullu bicimlendirme kullanmadan makro ile nasil yapabilirim acaba. tesekkür ederim.

 

[fedeal]

istediginiz böyle birşeymi

 

[dennisf06]

tesekkür ederim ilginize. formül ve kosullu bicimlendirme kullanmadan sadece makro ile nasil yapabilirim acaba. örnek dosyanizda hem formül var hemde kosulu bicimlendirme.

 

[Necdet]

Merhaba,

İstediğinizin veri giriş sırasında olmasını istiyorsanız eğer :

Aşağıdaki kodların ilgili sayfanın kod bölümünde olması gerekir.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [H:H]) Is Nothing Then Exit Sub
If Target <> Target.Offset(0, -2) Then
    Target.Offset(0, 1) = Target.Offset(0, -2) - Target
    Target.Offset(0, 1).Interior.ColorIndex = 3
Else
    Target.Offset(0, 1) = ""
    Target.Offset(0, 1).Interior.ColorIndex = xlNone
End If
Son:
End Sub

 

[Skorpiyon]

Alternatif olsun.

 

[masuk500]

şaban hocam
dört işlem için nasıl olur.yani matematiksel formüller yerine makro.

 

[Skorpiyon]

Sayın masuk500,

Güzel olur

Şaka bir yana sorunuzu tam olarak anlayamadım. Sayfada dört işlem için formüller yerine makro mu kullanmak istiyorsunuz ?

 

[masuk500]

evet çok güzel ifade ettiniz nedenine gelince hem hız açısından hemde dosyayı bir tek ben kullanmadığımdan dolayı

 

[Skorpiyon]

Sayın masuk500,

İstediğinize dair bir örnek ekleyin, yapıp yapamayacağımıza bir bakalım.

 

[Necdet]

dosyayı bir tek ben kullanmadığımdan

Paylaşımda olan bir dosya mı var?
Eğer paylaşıma açık dosya varsa makro çalışmıyor.

 

[masuk500]

dosya ektedir örneğin müstahsilgiriş sayfasındaki formüller

 

[masuk500]

Paylaşımda olan bir dosya mı var?
Eğer paylaşıma açık dosya varsa makro çalışmıyor.

paylaşım değil aynı pc de farklı 3 kişi tarafından kullanılıyor diye söyledim

ayrıca sayfa koruma şifreside 8630764862

 

[Skorpiyon]

Sayın masuk500,

İstediğiniz yapılabilir sanıyorum. Yalnız bu gece çok geç oldu. Daha müsait bir zamanda bakar, yapıp yapamayacağımızı burdan bildiririz.

 

[masuk500]

tabi ne demek şaban hocam
ben aslında forumda açılan bir başlıkta bu konu ile uygulama vardı,onu denedim ama bu defada dosya çok ağırlaştı.bundan dolayı vazgeçmiştim.ikinci olarak userform kullanarak yapmaya çalıştım onuda beceremedim açıkçası.hersayfada binlerce formül var oda dosyayı ağırlaştıryor.bu yüzden kod olsa hızlanır düşüncesindeyim.belkide yanılıyorum.....

 

[dennisf06]

Sn Necdet ve Sn Saban hocam ikinizede cok tesekkür ederim. yalniz Necdet bey sizin yazdiginiz kodlarda söyle bir problemle karsilastim. ayni sayfada iki tane Private Sub Worksheet_Change(ByVal Target As Range) ile baslayan makro oldu. bu yüzden sanirim kodlar islemi gerceklestirmedi. ismini degistirmeye calistim gene olmadi. ne yapmam gerekiyor acaba.

 

[Skorpiyon]

Önceki makronuzu da eklerseniz, ikisini birbirine uyarlamaya çalışabiliriz.

 

[dennisf06]

merhaba Sn. Saban bey. kodlar asagidaki gibidir.

1.kod mükerrer kayit icin. D sütununda ayni rakam girisi olunca uyari veriyor.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [d:d]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
On Error GoTo Son
If WorksheetFunction.CountIf(Range("d:d"), Target.Value) >= 2 Then
MsgBox "[ " & Target.Value & " ] Bu rakamla daha önce kayit yapildi.!", vbCritical, "DIKKAT"
End If
Son:
End Sub

2.kod Sn Necdet hocamiza ait.
Private Sub Worksheet_Changea(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [H:H]) Is Nothing Then Exit Sub
If Target <> Target.Offset(0, -2) Then
Target.Offset(0, 1) = Target.Offset(0, -2) - Target
Target.Offset(0, 1).Interior.ColorIndex = 3
Else
Target.Offset(0, 1) = ""
Target.Offset(0, 1).Interior.ColorIndex = xlNone
End If
Son:
End Sub

 

[Skorpiyon]

Say&#305;n dennisf06,

Ben kontrol etmedim ama (i&#351;in kolay&#305;na ka&#231;arak) a&#351;a&#287;&#305;daki &#351;ekilde bir dener misiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [d:d]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
On Error GoTo Son
If WorksheetFunction.CountIf(Range("d:d"), Target.Value) >= 2 Then
MsgBox "[ " & Target.Value & " ] Bu rakamla daha &#246;nce kayit yapildi.!", vbCritical, "DIKKAT"
End If
If Intersect(Target, [H:H]) Is Nothing Then Exit Sub
If Target <> Target.Offset(0, -2) Then
Target.Offset(0, 1) = Target.Offset(0, -2) - Target
Target.Offset(0, 1).Interior.ColorIndex = 3
Else
Target.Offset(0, 1) = ""
Target.Offset(0, 1).Interior.ColorIndex = xlNone
End If
Son:
End Sub

 

[dennisf06]

m&#252;kerrer kayit calisiyor ama digeri calismiyor.

 

[Skorpiyon]

Say&#305;n dennisf06,

A&#351;a&#287;&#305;daki &#351;ekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [d:d]) Is Nothing Then GoTo 20
If Target.Value = "" Then Exit Sub
On Error GoTo Son
If WorksheetFunction.CountIf(Range("d:d"), Target.Value) >= 2 Then
MsgBox "[ " & Target.Value & " ] Bu rakamla daha &#246;nce kayit yapildi.!", vbCritical, "DIKKAT"
End If
20
If Intersect(Target, [H:H]) Is Nothing Then Exit Sub
If Target <> Target.Offset(0, -2) Then
Target.Offset(0, 1) = Target.Offset(0, -2) - Target
Target.Offset(0, 1).Interior.ColorIndex = 3
Else
Target.Offset(0, 1) = ""
Target.Offset(0, 1).Interior.ColorIndex = xlNone
End If
Son:
End Sub