Sıra No Makro Biçimlendirilmiş Hücre

[ahuvan]

C16 dan itibaren 9 satırlık gurup birleştirilmiştir. Her gurup bir sıra numarasını ifade eder. G16 ve sonrasındaki her 10. satıra değer girildiğinde sıra numaraları otomatik artmalı. ancak aralarda değer girilmeyen kısımlara numarasız geçilmeli. Ben birşeyler yapmaya çalıştım ancak bazı problemler var. Örneğin G sütünuna değer girdiğimde sıra veriyor ama sildiğimde sıra no silinmiyor.

Ekte dosyayı gönderiyorum. Sarı hücrelere değer girdiğimde kırmızı hücrelere sıra no verilmeli. yeşil hücrelere değer girilirse sıra numaraları etkilenmemeli. Aralarda boş sarı hücre bırakılırsa o hücreye denk gelen kırmızı sıra numarası boş geçilerek sıralamaya kaldığı yerden devam edilmeli..
Değerli Arkadaşlar dar bir zamanda bitirilmesi gereken bir dosya acil desteklerinizi bekliyorum. Şimdiden teşekkür ederim...

 

[Necdet]

Merhaba,

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayıp dener misiniz?

Aradan satır silindiğinde ne olacak o belli değil, ama sondan satır sildiğinizde sıralama değişmeyecektir.

Bir inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [G:G]) Is Nothing Or _
        Selection.Count > 0 Or _
        Target.Row < 16 Or _
        (Target.Row - 16) Mod 9 > 0 Then Exit Sub
    If Target.Value = "" Then
        Target.Offset(0, -4) = ""
    Else
        Target.Offset(0, -4) = Application.WorksheetFunction.Max(Range("C16:C" & Target.Row)) + 1
    End If
    
End Sub

 

[ahuvan]

Necdet bey öncelikle ilginize teşekkür ederim, hemen denedim. Arada bir sarı hücrenin değerini sildiğimde hata kodu veriyor

If Target.Value = "" Then

 

[Necdet]

Merhaba,

Selection.Count ibaresini ekledim, tekrar dener misiniz?

Sanırım birden fazla hücreyi seçtiğinizde bu hata kodunu alıyorsunuz.

 

[ahuvan]

Selection Count > 0 yaptığımda hiç hesaplamadı yani kırmızı hücreleri numaralandırmadı.
öncekinde sırayla veya aralıklı sarı hücrelere değer verdiğimde problem olmuyordu. sadece aralardan bir veya iki sarı hücreyi sildiğimde hata veriyordu

 

[Necdet]

Silme işleminde sorun yaşanacağı kesin bu mantıkta.

Silme işlemini nasıl yapıyorsunuz? Bunları anlatırsanız aynı senaryoyu bende deneyebilirim.

Şimdi görmeden sizin ne yaptığınızı anlamaya çalışıyorum.

ben sadece sarı hücrelere giriş ya da değişiklik yapıldığında numara verdirmeye çalışıyorum. Silme işini nasıl yaptığınızı bilmiyorum.

Ortadan bir yerden silerseniz numaralandırma yanlış olur. Eğer böyle bir durum varsa onu bilmek gerek.

 

[ahuvan]

 Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [G:G]) Is Nothing Or _
        Target.Row < 16 Or _
        (Target.Row - 16) Mod 9 > 0 Then Exit Sub
    If Target.Value = "" Then
        Target.Offset(0, -4) = ""
    Else
        Target.Offset(0, -4) = Application.WorksheetFunction.Max(Range("C16:C" & Target.Row)) + 1
    End If
    
End Sub

Bu kod şimdilik iki hata veriyor aradaki sarı hücre değerlerini sildiğimde alt satırlardaki kırmızı hücre değerleri azalmıyor ve If Target.Value = "" Then kısmında hata veriyor.

Alt satırlardaki numaraların değişmemesini max count ile düzeltmek mümkün mü

 

[ahuvan]

Şöyle anlatmaya çalışayım. G6 dan G100 e kadar her satırda sarı veya yeşil hücrelerde değer girilmiş olsun. Bu durumda kırmızı hücrelere sıralı numaralandırma yapıyor. Ancak G34 vey G43 veya G52 hücrelerindeki değerleri silince C43 veya altındaki tüm kırmızı hücreler sıralı numaralandırılmıyor. eski numarada kalıyorlar.

 

[ahuvan]

Neşet Bey hata durumunu örnek dosya ile gönderiyorum. Görüleceği üzere sıra no 4 ten & ya atlamış. Oysaki aradaki hücreler silindikçe alltaki sıra numarası küçülmeli. 70, 79 ve 88. satırlar doluydu. silince 97. satır aynen kaldı

 

[Korhan Ayhan]

Merhaba,

Birde aşağıdaki kodu deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("G16:G65536")) Is Nothing Then Exit Sub
    
    Range("C16:C" & Rows.Count).ClearContents
    
    For Each Veri In Range("G16:G1000")
        If Veri.Row Mod 9 = 7 Then
            If Veri.Value <> "" Then
                Veri.Offset(0, -4) = WorksheetFunction.Max(Range("C16:C" & Veri.Row)) + 1
            End If
        End If
    Next
End Sub

 

[Necdet]

Evet düşündüğüm çözümü Korhan bey verdi.
Onu kullanabilirsiniz.

 

[ahuvan]

Senaryo Şu...
Ekte gönderdiğim dosyada personel sayfasında Sarı hücrelerde Evet yazan Personelin isimleri, sıra numaraları ve ücret türü evet olan satırlar bir başka sayfadaki puantaj aktarılıyor VBA kodu ile. Ancak bu personelden bazıları hiç ücret almadığı için veri kaydı olmasına rağmen sarı hücredeki eveti silerek o personeli puantaj cetveline aktarmıyoruz.
Bu senaryoya göre =Eğer(g16<>0;MAK(C16;1);"") ile sıra numarası verdirdim ve fill out yaptım. fakat zaman zaman personel listesini bozmadan araya 9 satır ekledik ve yeni bir personel ekleyince formülü yeniden en baştan fill out yapmak gerekiyor her defasında. bu soruna çözüm arıyorum.

 

[ahuvan]

Arkadaşlar harikasınız... Necdet bey Korhan bey çok minnettarım... Her daim başarılı olun....

 

[ahuvan]

SORUN ÇÖZÜLMÜŞTÜR. Necdet Yeşertener ve Korhan Ayhan Beyin Sorunu Çözmüştür. Çok Teşekkür Ederim...

 

[Necdet]

Merhaba,

Sorun çözüldü ama dün gece vakit bulup yapamadığım kodları da vereyim, içimde kalmasın, alternatif olsun.

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

 Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [G:G]) Is Nothing Or _
        Target.Row < 16 Or _
        (Target.Row - 16) Mod 9 > 0 Then Exit Sub
    Dim i As Long
    Dim SonSat  As Long
    Dim SiraNo  As Long
        
    SonSat = Cells(Rows.Count, "G").End(3).Row
    If SonSat < 16 Then SonSat = 16
    i = 16
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Do
        If Cells(i, "G") = "" Then
            Cells(i, "C") = ""
        Else
            Adet = Adet + 1
            Cells(i, "C") = Adet
        End If
        i = i + 9
    Loop While i <= SonSat
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub