formülleriyle satır ekleme, koşullu biçimlendirme vs makroları

uzmanamele · 13 Kasım 2007

merhaba
biraz karışık bir çalışma kitabım var ve bazı koşulları sağlayan veri girişlerini makro ile yapmak istiyorum.
birkısmını koşullu biçimlendirme, veri doğrulama vs gibi fonksiyonlarla yapmak mümkün ancak makro olursa makbule geçecek. zira ne kadar çok fonksiyon ve formül kullanılırsa dosya boyutu çok büyüyor. şuanki boyutu 25 MB ve dosya çalışması yavaşlayıp hantallaşıyor.
1- D sütununa yazılan metin; eğer C sütunu hücresindeki değerin son 2 karakteri "00" ise BÜYÜK HARFLE VE KIRMIZI RENKTE, C deki son 2 karakter "00" dan farklı ise YAZIM DÜZENİ İLE MAVİ RENKTE yazsın.
2- C sütununda; ayraç olarak nokta " . " virgül " , " bölü " / " eksi " - " işaretleri ve 0~9 arasındaki rakamlardan başka karakter kullanılınca uyarı mesajı versin. Ayraç dahil 5 karakterden uzun olursa kabul etmesin.
3- D sütununa yazılan metin; eğer başlangıçta seçilen hücre yüksekliğine sığmıyorsa EN UYGUN YÜKSEKLİKTE yazsın.
4- başlangıçta 25 satır olduğu düşünülürse, 26. satırdan sonra sayfa toplamı vs gibi 5 satırlık değiştirilmeyecek değerlerim olduğu düşünülürse; 25. satırın başlangıçtaki son satır olması sebebiyle C25 veya D25 HÜCRESİNE VERİ GİRİLDİĞİNDE ALTA SATIR EKLEYİP, ÜST SATIRDAKİ FORMÜLÜ KOPYALASIN.
5- C sütununa MÜKERRER KAYIT GİRİLİNCE SİLSİN ve UYARI MESAJI VERSİN (mümkünse makro ile, değilse veri doğrulamadan yapabilirim)
6- C sütunundaki verinin son 2 karakteri "00" ise KIRMIZI RENKTE değilse MAVİ RENKTE yazsın (mümkünse makro ile, değilse koşullu biçimlendirmeyle yapabilirim)

not: istediğim bazı makroların sitede olduğunu biliyorum, gerekli linki vermenizde yeterli olur.
aslında bu çalışma kitabında daha çok makro gerekiyor ancak şimdilik bunları ilave edeceğim. çok fazla makroya ihtiyacım olduğu için sitede ararken kendi yolumu şaşırdım açıkcası

uzmanamele · 13 Kasım 2007

istediğim bütün makroların aynı anda verilmesine gerek yok, 6 adet makroyu ayrı ayrı bulabilirsem daha iyi olur, dosyaya kendim adapte etmeyi becerebilirim galiba.

uzmanamele · 13 Kasım 2007

çalışma kitabının 25 MB olmasının sebebi karmaşık formüllerden ve büyük sayfa yapısından kaynaklanıyor. bu formülleri makro ile yazarsak, belki her veri girişinde aynı hesapları yapacak olduğundan çalışması yine yavaş olacaktır ama dosya boyutunu tahminen nekadara düşürür?

uzmanamele · 13 Kasım 2007

merhaba
istediğim kodların biraz uzun olduğunu kabul etmek lazım. o nedenle bazı kodları iptal etmekta fayda var.

1- D sütununa yazılan metin; eğer C sütunu hücresindeki değerin son 2 karakteri "00" ise BÜYÜK HARFLE VE KIRMIZI RENKTE, C deki son 2 karakter "00" dan farklı ise YAZIM DÜZENİ İLE MAVİ RENKTE yazsın.
2- başlangıçta 25 satır olduğu düşünülürse, 26. satırdan sonra sayfa toplamı vs gibi 5 satırlık değiştirilmeyecek değerlerim olduğu düşünülürse; 25. satırın başlangıçtaki son satır olması sebebiyle C25 veya D25 HÜCRESİNE VERİ GİRİLDİĞİNDE ALTA SATIR EKLEYİP, ÜST SATIRDAKİ FORMÜLÜ KOPYALASIN.

uzmanamele · 14 Kasım 2007

sorunun ratingi yüksek ama monolok seyrediyoruz. gündemde tutmak için butür mesajlar yazmak zorunda kalıyorum.

uzmanamele · 14 Kasım 2007

merhaba
D sütunu koşullu biçimlendirme formülü; =EĞER(SAĞDAN($C4;2)="00";1;0)
C sütunu koşullu biçimlendirme formülü; =EĞER(SAĞDAN($C5;2)="00";1;0)
bu koşullu biçimlendirme ile hücredeki metin renklerini değiştirebiliyorum.
benzer şekilde;
=EĞER((SAĞDAN($C4;2)="00");BÜYÜKHARF($D4);YAZIM.DÜZENİ($D4))
bu formül başka hücrede çalışıyor ama D4 hücresine koşullu biçimlendirme yaptırmak isteyince olmuyor.
koşullu biçimlendirmede metin biçimini nasıl değiştiririz?

ekteki dosyada, sayfa2 de koşullu biçimlendirme var ancak koşullu biçimlendirme ile büyükharf() ve yazım.düzeni() fonksiyonlarını uyarlayamadım.

aslında aradığım bu biçimlendirme için vba kodu, şimdilik koşullu biçimlendirme ile yetinebilirim.

uzmanamele · 14 Kasım 2007

soru, A-B grubunda 113 rating almış ama monolok seyrediyoruz. gündemde tutmak için butür mesajlar yazmak zorunda kalıyorum.

Ferhat Pazarçevirdi · 14 Kasım 2007

Merhabalar,

1 Nolu mesajınıza istinaden (çünkü diğer mesajlarınızı incelemedim), aşağıdakileri KEŞİF adlı sheet'in kod sayfasına kopyalayınız veya örnek dosyayı inceleyiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo f1
Select Case Target.Column
   Case 3
       arrchar = Array("/", ".", ",", "-", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0")
       For i = 1 To Len(Target)
           For j = 0 To UBound(arrchar)
               If Mid(Target, i, 1) = arrchar(j) Then: x = x + 1
           Next j
           If x = 0 Then
              MsgBox "Girdiğiniz veri, kurallara uygun değil", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit For
           End If
           x = 0
       Next i
       For i = 2 To Cells(65536, 3).End(xlUp).Row
           If Target.Address <> Cells(i, 3).Address Then
           If Cells(i, 3) = Target Then
              MsgBox "Bu değerden zaten bir tane var", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit Sub
           End If
           End If
       Next i
   
   Call Sekillendir(Target.Offset(0, 1))
   Case 4 'D sütununa veri girişi yapılırsa
       Call Sekillendir(Target)
       Cells(65536, 4) = Target
       With Cells(65536, 4)
           .WrapText = True
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
'           .EntireRow.AutoFit
       End With
       Rows("65536:65536").EntireRow.AutoFit
       If Rows("65536").RowHeight > Rows(Target.Row).RowHeight Then
          Rows(Target.Row).RowHeight = Rows(65536).RowHeight
       Else
          Rows(Target.Row).RowHeight = 30
       End If
End Select
f1:
Application.EnableEvents = True
End Sub
[COLOR=green]'---------------------------------------------[/COLOR]
Sub Sekillendir(hcr As Range)
If Right(Cells(hcr.Row, 3), 2) = "00" Then
    Cells(hcr.Row, 4) = UCase(Replace(Replace(Cells(hcr.Row, 4), "ı", "I"), "i", "İ"))
    Cells(hcr.Row, 4).Font.ColorIndex = 3
ElseIf Right(Cells(hcr.Row, 3), 2) = Empty Then
    Cells(hcr.Row, 4).Font.ColorIndex = 1
    Cells(hcr.Row, 4).Select
Else
    Cells(hcr.Row, 4) = Application.WorksheetFunction.Proper(hcr)
    Cells(hcr.Row, 4).Font.ColorIndex = 5
End If
End Sub

uzmanamele · 14 Kasım 2007

syn fpc, teşekkürler. çalışmanızı inceleyip tekrar dönerim. ilginize teşekkürler

uzmanamele · 14 Kasım 2007

fpc' Alıntı:

Merhabalar,

1 Nolu mesajınıza istinaden (çünkü diğer mesajlarınızı incelemedim), aşağıdakileri KEŞİF adlı sheet'in kod sayfasına kopyalayınız veya örnek dosyayı inceleyiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo f1
Select Case Target.Column
   Case 3
       arrchar = Array("/", ".", ",", "-", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0")
       For i = 1 To Len(Target)
           For j = 0 To UBound(arrchar)
               If Mid(Target, i, 1) = arrchar(j) Then: x = x + 1
           Next j
           If x = 0 Then
              MsgBox "Girdiğiniz veri, kurallara uygun değil", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit For
           End If
           x = 0
       Next i
       For i = 2 To Cells(65536, 3).End(xlUp).Row
           If Target.Address <> Cells(i, 3).Address Then
           If Cells(i, 3) = Target Then
              MsgBox "Bu değerden zaten bir tane var", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              [COLOR="Red"]Exit Sub[/COLOR] [COLOR="Teal"]'Sanırım Exit Sub yerine Exit For yazılması gerekiyor[/COLOR]
           End If
           End If
       Next i
   
   Call Sekillendir(Target.Offset(0, 1))
   Case 4 'D sütununa veri girişi yapılırsa
       Call Sekillendir(Target)
       Cells(65536, 4) = Target
       With Cells(65536, 4)
           .WrapText = True
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
'           .EntireRow.AutoFit
       End With
       Rows("65536:65536").EntireRow.AutoFit
       If Rows("65536").RowHeight > Rows(Target.Row).RowHeight Then
          Rows(Target.Row).RowHeight = Rows(65536).RowHeight
       Else
          Rows(Target.Row).RowHeight = 30
       End If
End Select
f1:
Application.EnableEvents = True
End Sub
[COLOR=green]'---------------------------------------------[/COLOR]
Sub Sekillendir(hcr As Range)
If Right(Cells(hcr.Row, 3), 2) = "00" Then
    Cells(hcr.Row, 4) = UCase(Replace(Replace(Cells(hcr.Row, 4), "ı", "I"), "i", "İ"))
    Cells(hcr.Row, 4).Font.ColorIndex = 3
ElseIf Right(Cells(hcr.Row, 3), 2) = Empty Then
    Cells(hcr.Row, 4).Font.ColorIndex = 1
    Cells(hcr.Row, 4).Select
Else
    Cells(hcr.Row, 4) = Application.WorksheetFunction.Proper(hcr)
    Cells(hcr.Row, 4).Font.ColorIndex = 5
End If
End Sub

sanırım For-Next döngüsünde bir hata var, Exit Sub yerine Exit For olması gerekir

uzmanamele · 14 Kasım 2007

syn fpc, alıntı yaparak cevaplamaya çalışırken sizin mesajı istemeden değiştirmişin, özür.

uzmanamele · 14 Kasım 2007

For i = 2 To Cells(65536, 3).End(xlUp).Row
If Target.Address <> Cells(i, 3).Address Then
If Cells(i, 3) = Target Then
MsgBox "Bu değerden zaten bir tane var", vbCritical, "UYARI"
Target = Empty
Target.Select
Exit For
End If
End If
Next i

Exit For şeklinde düzeltince gayet güzel olmuş. eliniza sağlık.
C sütununda ayraç ve 0~9 arası sayı girişi kontrolüde gayet güzel olmuş. bu sütunda toplam 5 karakter ve 3. karakterin ayraç olması şartını koyabilir miyiz? ayrıca c sütunda son 2 karakter "00" ise kırmızı, değilse mavi ile yazdırabilir miyiz?

Ferhat Pazarçevirdi · 14 Kasım 2007

Exit For şeklinde düzeltince gayet güzel olmuş. eliniza sağlık

Burada, Exit For amaca uygun değil, çünkü prosedürün bu aşaması, mükerrer kayıt kontrolüne ait. Eğer mükerrer bir kayıt bulunursa, prosedürün bundan sonraki satırlarının çalıştırılmaması lazım. Oysa ki, Exit For sadece döngüden çıkar, diğer adımların hepsini gerçekleştirir.

Exit For'la doğru sonuç almanız tamamen tesadüften ibarettir. İleri de değişik veriler girdiğinizde problem çıkarır.

C sütununda ayraç ve 0~9 arası sayı girişi kontrolüde gayet güzel olmuş. bu sütunda toplam 5 karakter ve 3. karakterin ayraç olması şartını koyabilir miyiz?

Koyulabilir. Problem değil.

ayrıca c sütunda son 2 karakter "00" ise kırmızı, değilse mavi ile yazdırabilir miyiz?

Bu zaten kodlarda var. Benim yaptığım testlerde, sonunda "00" yazanların açıklaması kırmızı ve BÜYÜK, "00"dan farklı ise mavi ve Yazım.Düzeni'nde sonuç veriyor. Yani istediğiniz gibi .... Eğer, kod boş geçilirse de siyah font kullanıyor.

Buradaki isteğinizi tam olarak anlayamadım.

uzmanamele · 14 Kasım 2007

fpc' Alıntı:
Burada, Exit For amaca uygun değil, çünkü prosedürün bu aşaması, mükerrer kayıt kontrolüne ait. Eğer mükerrer bir kayıt bulunursa, prosedürün bundan sonraki satırlarının çalıştırılmaması lazım. Oysa ki, Exit For sadece döngüden çıkar, diğer adımların hepsini gerçekleştirir.

Exit For'la doğru sonuç almanız tamamen tesadüften ibarettir. İleri de değişik veriler girdiğinizde problem çıkarır.

C sütununa mükerrer kayıt girince msg box uyarı veriyor ancak sonraki veri girişi Exit Sub olunca makroyu kapatıyor gibi algılıyorum, yani sonraki girişlerde makro çalışmıyor.

Bu zaten kodlarda var. Benim yaptığım testlerde, sonunda "00" yazanların açıklaması kırmızı ve BÜYÜK, "00"dan farklı ise mavi ve Yazım.Düzeni'nde sonuç veriyor. Yani istediğiniz gibi .... Eğer, kod boş geçilirse de siyah font kullanıyor.

Buradaki isteğinizi tam olarak anlayamadım.

C sütununa veri girişi yapıldığında koşula bağlı olarak D sütunundaki metinlerin rengi ve yazı tipi değişiyor, ancak aynı şekilde C sütunudaki verilerde aynı renkte kırmızı veya mavi renk olacak.

Ferhat Pazarçevirdi · 14 Kasım 2007

Vallahi, kusura bakma

... Ben anladım ki, D sütunu renklenmiyor ?

Tamam onu da hallederiz.

Ferhat Pazarçevirdi · 14 Kasım 2007

Kodları aşağıdaki gibi değiştirdim. Bunu deneyiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo f1
Select Case Target.Column
   Case 3
       If Target = Empty Then: GoTo f1
       arrchar = Array("/", ".", ",", "-", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0")
       If Len(Target) = 5 Then
          For i = 0 To 3
              If Mid(Target.Value, 3, 1) = arrchar(i) Then: x = x + 1
          Next i
          If x = 0 Then
             MsgBox "XX.XX gibi bir değer girmeniz gerek", vbCritical, "UYARI"
             x = 0
             Target = Empty
             Target.Select
             GoTo f1
          End If
       Else
          MsgBox "Toplam 5 karakter uzunluğunda bir kodlama yapmalısınız" _
                & vbCrLf & "XX.XX gibi ...", vbCritical, "UYARI"
          Target = Empty
          Target.Select
          GoTo f1
       End If
       For i = 1 To Len(Target)
           For j = 0 To UBound(arrchar)
               If Mid(Target, i, 1) = arrchar(j) Then: x = x + 1
           Next j
           If x = 0 Then
              MsgBox "Girdiğiniz veri, kurallara uygun değil", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit For
           End If
           x = 0
       Next i
       For i = 2 To Cells(65536, 3).End(xlUp).Row
           If Target.Address <> Cells(i, 3).Address Then
           If Cells(i, 3) = Target Then
              MsgBox "Bu değerden zaten bir tane var", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit Sub
           End If
           End If
       Next i
   
   Call Sekillendir(Target.Offset(0, 1))
   Case 4 'D sütununa veri girişi yapılırsa
       Call Sekillendir(Target)
       Cells(65536, 4) = Target
       With Cells(65536, 4)
           .WrapText = True
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
'           .EntireRow.AutoFit
       End With
       Rows("65536:65536").EntireRow.AutoFit
       If Rows("65536").RowHeight > Rows(Target.Row).RowHeight Then
          Rows(Target.Row).RowHeight = Rows(65536).RowHeight
       Else
          Rows(Target.Row).RowHeight = 30
       End If
End Select
f1:
Application.EnableEvents = True
End Sub
Sub Sekillendir(hcr As Range)
If Right(Cells(hcr.Row, 3), 2) = "00" Then
    Cells(hcr.Row, 4) = UCase(Replace(Replace(Cells(hcr.Row, 4), "ı", "I"), "i", "İ"))
    Cells(hcr.Row, 4).Font.ColorIndex = 3
    Cells(hcr.Row, 3).Font.ColorIndex = 3
ElseIf Right(Cells(hcr.Row, 3), 2) = Empty Then
    Cells(hcr.Row, 4).Font.ColorIndex = 1
    Cells(hcr.Row, 3).Font.ColorIndex = 1
    Cells(hcr.Row, 4).Select
Else
    Cells(hcr.Row, 4) = Application.WorksheetFunction.Proper(hcr)
    Cells(hcr.Row, 4).Font.ColorIndex = 5
    Cells(hcr.Row, 3).Font.ColorIndex = 5
End If
End Sub

uzmanamele · 15 Kasım 2007

C sütunundaki renklendirme sorunu çözülmüş, elinize sağlık.
mükerrer kayıt girişinde sorun var. msgbox dan sonra makro çalışmıyor. birdaha bakarmısınız?

Exit Sub yerine Exit For olacak gibime geliyor.

Exit Sub makroyu kapatmaz mı?
Exit For komutu belki tesadüfen işledi ama sonraki sorgu başlangıcına dönmesi lazım.

Ferhat Pazarçevirdi · 15 Kasım 2007

Hangi verileri işlerken hata aldığınızı bana tek tek yazabilir misiniz ? MEsela, C'ye bunu yazarken şu hatayı aldım gibi ....

uzmanamele · 15 Kasım 2007

c sütununa 02.02 kodu mükerrer giriş yapırken msgbox uyarı veriyor, veriyi düzeltince makro çalışmıyor

Ferhat Pazarçevirdi · 15 Kasım 2007

Exit Sub olmayacak tabi ... Ama Exit For'da olmayacak

Exit Sub yerine, Goto f1 yazılacak. Kırmızı ile kodlarda işaretledim.

Ah şu, EnableEvents .... Güzel birşey ama bir boş bıraktın mı kodların hemen sonunu getiriyor ...

Kodun son hali aşağıdaki gibi yani

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo f1
Select Case Target.Column
   Case 3
       If Target = Empty Then: GoTo f1
       arrchar = Array("/", ".", ",", "-", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0")
       If Len(Target) = 5 Then
          For i = 0 To 3
              If Mid(Target.Value, 3, 1) = arrchar(i) Then: x = x + 1
          Next i
          If x = 0 Then
             MsgBox "XX.XX gibi bir de&#287;er girmeniz gerek", vbCritical, "UYARI"
             x = 0
             Target = Empty
             Target.Select
             GoTo f1
          End If
       Else
          MsgBox "Toplam 5 karakter uzunlu&#287;unda bir kodlama yapmal&#305;s&#305;n&#305;z" _
                & vbCrLf & "XX.XX gibi ...", vbCritical, "UYARI"
          Target = Empty
          Target.Select
          GoTo f1
       End If
       For i = 1 To Len(Target)
           For j = 0 To UBound(arrchar)
               If Mid(Target, i, 1) = arrchar(j) Then: x = x + 1
           Next j
           If x = 0 Then
              MsgBox "Girdi&#287;iniz veri, kurallara uygun de&#287;il", vbCritical, "UYARI"
              Target = Empty
              Target.Select
              Exit For
           End If
           x = 0
       Next i
       For i = 2 To Cells(65536, 3).End(xlUp).Row
           If Target.Address <> Cells(i, 3).Address Then
           If Cells(i, 3) = Target Then
              MsgBox "Bu de&#287;erden zaten bir tane var", vbCritical, "UYARI"
              Target = Empty
              Target.Select
[COLOR=red][B]           GoTo f1[/B][/COLOR]
           End If
           End If
       Next i
 
   Call Sekillendir(Target.Offset(0, 1))
   Case 4 'D s&#252;tununa veri giri&#351;i yap&#305;l&#305;rsa
       Call Sekillendir(Target)
       Cells(65536, 4) = Target
       With Cells(65536, 4)
           .WrapText = True
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
'           .EntireRow.AutoFit
       End With
       Rows("65536:65536").EntireRow.AutoFit
       If Rows("65536").RowHeight > Rows(Target.Row).RowHeight Then
          Rows(Target.Row).RowHeight = Rows(65536).RowHeight
       Else
          Rows(Target.Row).RowHeight = 30
       End If
End Select
f1:
Application.EnableEvents = True
End Sub
Sub Sekillendir(hcr As Range)
If Right(Cells(hcr.Row, 3), 2) = "00" Then
    Cells(hcr.Row, 4) = UCase(Replace(Replace(Cells(hcr.Row, 4), "&#305;", "I"), "i", "&#304;"))
    Cells(hcr.Row, 4).Font.ColorIndex = 3
    Cells(hcr.Row, 3).Font.ColorIndex = 3
ElseIf Right(Cells(hcr.Row, 3), 2) = Empty Then
    Cells(hcr.Row, 4).Font.ColorIndex = 1
    Cells(hcr.Row, 3).Font.ColorIndex = 1
    Cells(hcr.Row, 4).Select
Else
    Cells(hcr.Row, 4) = Application.WorksheetFunction.Proper(hcr)
    Cells(hcr.Row, 4).Font.ColorIndex = 5
    Cells(hcr.Row, 3).Font.ColorIndex = 5
End If
End Sub

ÖNEMLİ NOT : Muhtemelen EnableEvents şu an false'tur. Onun için ya Excel'i açıp kapatın yada aşağıdaki kodu bir defalığına çalıştırın.

Sub OlaylariTetikle()
Application.EnableEvents=True
End Sub

formülleriyle satır ekleme, koşullu biçimlendirme vs makroları

Uzman

Uzman

Uzman

Uzman

Uzman

Uzman

Uzman

Özel Üye

Uzman

Uzman

Uzman

Uzman

Özel Üye

Uzman

Özel Üye

Özel Üye

Uzman

Özel Üye

Uzman

Özel Üye