farklı isimlerde, FARKI VURGULAMA !

[atraks]

ekteki dosyada farklı firma isimleri arasına mevcut makroya göre, save tuşuna basar basmaz araya boş satır atayarak dosyayı kaydediyor.
fakat boş satır atma işi bazı sorunlara yol açıyor, bu sebeple bu makronun iptal edilip,
farklı firma isimlerini açık gri dolgu rengiyle vurgulamasını istiyorum.
yani gri-beyaz, gri-beyaz gidecek.

yardımlarınız için teşekkürler.

 

[Orion1]

Dosyanız ektedir.
Before save olayında hata veriyortu.Onun için ilk satırda exit sub ile ondan çıktım.

Sub renk_ver_59()
    Dim i As Long, say As Long
    Sheets("SİPARİŞ").Select
    Application.ScreenUpdating = False
    Range("A3:Q1041000").Interior.ColorIndex = xlNone
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") <> Cells(i - 1, "A") Then
                say = say + 1
                If say Mod 2 = 0 Then Range("A" & i & ":Q" & i).Interior.ColorIndex = 16
                Cells(i, "M").FormulaR1C1 = Cells(i - 1, "M").FormulaR1C1
                Cells(i, "N").FormulaR1C1 = Cells(i - 1, "N").FormulaR1C1
                Cells(i, "O").FormulaR1C1 = Cells(i - 1, "O").FormulaR1C1
                Cells(i, "P").FormulaR1C1 = Cells(i - 1, "P").FormulaR1C1
                Cells(i, "Q").FormulaR1C1 = Cells(i - 1, "Q").FormulaR1C1
                Cells(i, "R").FormulaR1C1 = Cells(i - 1, "R").FormulaR1C1
                Cells(i, "S").FormulaR1C1 = Cells(i - 1, "S").FormulaR1C1
                Cells(i, "T").FormulaR1C1 = Cells(i - 1, "T").FormulaR1C1
        End If
    Next i
    Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı.Renklendirme Yapıldı." & vbLf & _
"Coder:evrengizlen@hotmail.com" & vbLf & "Date:21.07.2011", _
vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[atraks]

dosya açılmıyor, boyutu da aşırı büyümüş, bir hata mı oldu? ayrıca before save olayı neydiki? onu iptal ettiğinizi söylemişsiniz....save tuşuna basınca renklendirme olayı mıydı?
bu arada farklı isimler arasına boşluk atmayacak.sadece farklı isimleri dolgu rengiyle belli edecek

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu boş bir modüle uygulayın.

Sub RENKLENDİR()
    Dim i As Long, Renk As Byte, Say As Integer
 
    Application.ScreenUpdating = False
    Sheets("SİPARİŞ").Select
    Renk = 15
    Range("A3:Q" & Rows.Count).Interior.ColorIndex = xlNone
 
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(i, "A"))
        If Say = 1 Then
            Range("A" & i & ":Q" & i).Interior.ColorIndex = Renk
            Renk = IIf(Renk = 15, 0, 15)
        Else
            Range("A" & i & ":Q" & i + Say - 1).Interior.ColorIndex = Renk
            Renk = IIf(Renk = 15, 0, 15)
        End If
        i = i + Say - 1
    Next i
 
    Application.ScreenUpdating = True
End Sub

ThisWorkbook bölümündeki kayıt esnasında çalışan kodunuzuda aşağıdaki şekilde değiştirin ve deneyin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim d() As String, dosya As String, dosyaAdı As String, uzantı As String
 
    Call RENKLENDİR
 
    With ActiveWorkbook
        d = Split(.Name, ".")
        uzantı = d(UBound(d))
        dosyaAdı = Left(.Name, Len(.Name) - Len(uzantı) - 1)
 
        dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
            "\GÜNLÜK İMALAT" & Application.PathSeparator & _
            dosyaAdı & Format(Now, " dd.mm.yyyy_hh/mm") & "." & uzantı
            .SaveCopyAs Filename:=dosya
 
        dosya = "[URL="file://\\Dataserver\paylasım"]\\Dataserver\paylasım[/URL] radyal\GÜNLÜK İMALAT" & Application.PathSeparator & _
            dosyaAdı & Format(Now, " dd.mm.yyyy_hh/mm") & "." & uzantı
    .SaveCopyAs Filename:=dosya
 
    End With
End Sub

 

[Orion1]

dosya açılmıyor, boyutu da aşırı büyümüş, bir hata mı oldu? ayrıca before save olayı neydiki? onu iptal ettiğinizi söylemişsiniz....save tuşuna basınca renklendirme olayı mıydı?
bu arada farklı isimler arasına boşluk atmayacak.sadece farklı isimleri dolgu rengiyle belli edecek

Evet before save olayından bahsettim.
Ayrıca araya boşluk atmıyor.
Sayfa üzerine buton koydum.O butona tıklamalısınız.

 

[atraks]

cevaplarınız için teşekkür ederim arkadaşlar,
Sn Korhan,
Range("A3:Q" & Rows.Count).Interior.ColorIndex = xlNone satırlı kodda hata verdi. koddan anlamam ama Qdan sonra rakam verdim Q3 yaptım ama hata devam etti.

 

[Korhan Ayhan]

Merhaba,

"xlNone" yerine 0 yazıp denermisiniz.

 

[atraks]

bu defa da başka satır hata verdi...baştan düzeltmeniz mümkün mü acaba??

 

[Korhan Ayhan]

Merhaba,

Sn. atraks,

Ben kodları deneyerek foruma ekledim. Bende çalışıyor. Siz 2007 versiyon kullandığınız için sorun çıkarıyor olabilir.

Kod şimdi hangi satırda hata veriyor?

 

[atraks]

sn korhan,

yine Range("A3:Q" & Rows.Count).Interior.ColorIndex = 0 satırında hata veriyor. dosyayı ekledim. bakmanız mümkün mü?

 

[Korhan Ayhan]

Merhaba,

Sayfanıza SAYFA KORUMASI eklemişsiniz. İlk mesajınızdaki dosyada böyle bir özellik yok ayrıca mesaj içeriğinde de bildirmemişsiniz. Sorularınızı sorarken bu detayları belirtmezseniz maalesef bizlerin yapacağı çok fazla birşey yok.

Aşağıdaki kodu deneyin.

Sub RENKLENDİR()
    Dim i As Long, Renk As Byte, Say As Integer
 
    Application.ScreenUpdating = False
    Sheets("SİPARİŞ").Select
 
[COLOR=red]   ActiveSheet.Unprotect[/COLOR]
 
    Renk = 15
    Range("A3:Q" & Rows.Count).Interior.ColorIndex = xlNone
 
 
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(i, "A"))
        If Say = 1 Then
            Range("A" & i & ":Q" & i).Interior.ColorIndex = Renk
            Renk = IIf(Renk = 15, 0, 15)
        Else
            Range("A" & i & ":Q" & i + Say - 1).Interior.ColorIndex = Renk
            Renk = IIf(Renk = 15, 0, 15)
        End If
        i = i + Say - 1
    Next i
 
[COLOR=red]   ActiveSheet.Protect[/COLOR]
 
    Application.ScreenUpdating = True
End Sub

 

[atraks]

bunun belirtilmesi gereken bir şey olduğunu bilmiyordum, yoksa soruyu sorarken açık olması için azami gayret gösteriyorum, soru benim sorum çünkü.
cevaplarınız için teşekkürler...

 

[atraks]

Koray bey,

eğer yapmanız mümkünse şunlara göz arabilir misiniz?

ekteki dosyamda save tuşuna basınca otomatikman sayfa koruması da aktif oluyor, istediğim şu;

1- save tuşuna basınca sayfa koruması aktif olmasın
2-save tuşuna basınca tüm sayfaları otomatik olarak orada belirttiğim süzme kriterlerine göre sıralasın. ben şu anda her sayfa için kayıt işleminden hemen önce SIRALAMA işini tek tek yapıyorum. tek tuşla yapabilirsek çok büyük kolaylık olacaktır.
3-bir de eğer çok zor ve zahmetli olmayacak ise, SİPARİŞ sayfasında farklı firma isimlerinde fon rengini farklı atayarak sorunu çözmüştünüz.

Aynen bunun gibi ;

DİLİM sayfası için , 1.kriter model ismi, 2.kriter ise renk ismi olacak şekilde yine farklı dolgu renklerine boyasın.yani model ismi değiştiğinde taban rengi değişecek, model ismi aynı bile olsa renk değiştiğinde yine dolgu rengi değişecek.

ÜST KAPAK için;
model, renk ve uzunluk kriterlerine göre boyama yapacak. yani model değiştiğinde dolgu rengi değişir, modeller aynı ama renkler değişince dolgu rengi değişir, model ve renk aynı ama uzunluklar değişince dolgu rengi değişir olacak. eğer üçü de aynı ise dolgu rengi aynı kalır.

KOLLEKTÖR için;

kriterler model, renk olacak şekilde dolgu renklendirmesi . yapacak. yani model ismi değiştiğinde renk değişecek. model aynı renk değişince dolgu rengi değişecek.ikisi aynı ise renk aynı kalacak.

3. maddeyi yapmak uzun ve zahmetli olacaksa en azından 1 ve 2 . maddelere bakarsanız sevinirim.