Soru Filtreleme sonrası makro ile otomatik sıra numarası verme

[mustafa]

Merhabalar

Aşağıdaki kod, B sütununda ver varsa A sütununa otomatik sıra numarası veriyor. Filtreleme yapınca sıra numaraları yenileniyor. Kod çok güzel çalışıyor fakat 30 binde fazla satır olunca dosyanın boyutunu büyütüyor. Bu kodu makro olarak sayfaya nasıl uygularız?

=ALTTOPLAM(103;$B$6:B6)

 

[Korhan Ayhan]

Eski bir konu...

Filtreleme sonrası sıra numarası verme

Arkadaşlar diyelim ki a sütununda 1'den 100'e kadar karışık bir şekilde numaralar var. Ben A sütununa filtreleme yapıp sadece çift sayıları elle seçiyorum. Sonra bu sayıları küçükten büyüğe doğru sıralıyorum. Sıralama sonrasında karşısındaki hücreye de 1'den başlayarak numara vermek istiyorum...

www.excel.web.tr

 

[pitchoute]

Merhaba, bu şekilde deneyip sonucu paylaşabilir misiniz? Yedek almayı unutmayın lütfen;

Dim gorunenHucreler As Range   
Dim huc As Range               
Dim sira As Long               

Application.ScreenUpdating = False
sira = 1

On Error Resume Next
Set gorunenHucreler = Range("B6:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not gorunenHucreler Is Nothing Then
    For Each huc In gorunenHucreler
        If huc.Value <> "" Then
            Cells(huc.Row, "A").Value = sira
            sira = sira + 1
        Else
            Cells(huc.Row, "A").ClearContents
        End If
    Next huc
End If

Application.ScreenUpdating = True

 

[mustafa]

Eski bir konu...

Filtreleme sonrası sıra numarası verme

Arkadaşlar diyelim ki a sütununda 1'den 100'e kadar karışık bir şekilde numaralar var. Ben A sütununa filtreleme yapıp sadece çift sayıları elle seçiyorum. Sonra bu sayıları küçükten büyüğe doğru sıralıyorum. Sıralama sonrasında karşısındaki hücreye de 1'den başlayarak numara vermek istiyorum...

www.excel.web.tr

Üstat o konuya bakmıştım fakat her defasında sıra numarası verdirmek istemediğim için bu konuyu açtım. Yine de o kodu uyguladım dosyaya ama sıra numarası makro butonuna tıkladığımda 5 dk bekledim, böyle bekletecekse işime yaramaz ki. Bir de otomatik sıra numarası versin istiyorum. Çözümü yoksa kodla devam ederim.

 

[Korhan Ayhan]

Kodu sayfa olaylarına bağlarsanız otomatik olarak çalışacaktır. Ayrıca makro hızlandırma tekniklerini ekleyerek daha hızlı sonuçlar alabilirsiniz.

 

[mustafa]

Merhaba, bu şekilde deneyip sonucu paylaşabilir misiniz? Yedek almayı unutmayın lütfen;

Dim gorunenHucreler As Range  
Dim huc As Range              
Dim sira As Long              

Application.ScreenUpdating = False
sira = 1

On Error Resume Next
Set gorunenHucreler = Range("B6:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not gorunenHucreler Is Nothing Then
    For Each huc In gorunenHucreler
        If huc.Value <> "" Then
            Cells(huc.Row, "A").Value = sira
            sira = sira + 1
        Else
            Cells(huc.Row, "A").ClearContents
        End If
    Next huc
End If

Application.ScreenUpdating = True

Kodu butona ekledim ama bu kod da sıra numarası vermek için çok bekletiyor.

 

[mustafa]

Kodu sayfa olaylarına bağlarsanız otomatik olarak çalışacaktır. Ayrıca makro hızlandırma tekniklerini ekleyerek daha hızlı sonuçlar alabilirsiniz.

Üstat, maalesef bu dediğinizi yapabilecek kod bilgisine sahip değilim.

 

[Korhan Ayhan]

O zaman şöyle yapalım..

Bende yoldayım. Telefondan kod yazmak zor oluyor. Yapay zekadan kod yazma konusunda destek aldım. Kod tasarımı bana aittir.

Öncelikle sayfanızda boş bir hücreye aşağıdaki formülü uygulayınız. Ben Z1 hücresini kullandım.

=ALTTOPLAM(103;B6:B1048576)

Sonra sayfanızın kod bölümüne aşağıdaki kodu uygulayınız. Kodu test edemedim.

Sayfada filtre yaparak deneyiniz.

Option Explicit

Private Sub Worksheet_Calculate()
    Dim WS As Worksheet
    Dim Last_Row As Long
    Dim Filter_Data_Row As Long
    Dim Total_Data_Row As Long
    Dim Filter_Rng As Range
    Dim Rng As Variant
    Dim No As Long
    Dim First_Time As Double
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    First_Time = Timer
    Set WS = Me
    WS.Range("A6:A" & WS.Rows.Count).ClearContents
    Last_Row = WS.Cells(WS.Rows.Count, 2).End(3).Row
    Filter_Data_Row = WS.Range("Z1").Value
    On Error Resume Next
    Set Filter_Rng = WS.Range("A6:A" & Last_Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
   
    On Error GoTo 10
   
    If Not Filter_Rng Is Nothing Then
        Total_Data_Row = Last_Row - 5
   
        If Total_Data_Row = Filter_Data_Row Then
            WS.Range("A6").Value = 1
            WS.Range("A6").AutoFill Destination:=WS.Range("A6:A" & Last_Row), Type:=xlFillSeries
            WS.Range("AA1") = Timer - First_Time
        Else
            No = 1
            For Each Rng In Filter_Rng
                Rng.Value = No
                No = No + 1
            Next
           
            WS.Range("AA1") = Timer - First_Time
        End If
    End If
   
10  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

 

[mustafa]

Üstat olmadı, filtreleme sonrası Z1 hücresinde farklı bir sayı oluyor, sıralamada da değişiklik olmuyor.

Müsait olunca bakarsanız memnun olurum.

 

[Korhan Ayhan]

Üstteki mesajımı revize ettim. Son halini deneyiniz..

Bu ekte sunduğum dizi yöntemiyle sıra no vermektedir. Daha hızlı sonuç verebilir. Tek dezavantajı var olan filtreyi kaldırıp A sütunundaki yeni sıra numarası verdiği verileri filtrelemesidir. Yani sayfada uygulanan orjinal filtreleme kaybolmaktadır.

Kullanmak isteyebilirsiniz diye paylaşmak istedim.

 

[mustafa]

Üstat olmadı, filtreleme sonrası Z1 hücresinde farklı bir sayı oluyor, sıralamada da değişiklik olmuyor.

Müsait olunca bakarsanız memnun olurum.

Üstat, bu kod çalışıyor fakat aşağıdaki hücreyi renklendiren kodla çakışıyor galiba, hata veriyor. O kodu silince düzeliyor. Bunun sebebi ne olabilir?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
son = Cells(Rows.Count, 44).End(3).Row
If Target.Count = 1 Then
If Target.Column = 4 Or Target.Column = 5 Then
Range("AR6:AR" & son).Interior.Color = 15652797
Range("AS6:AS" & son).Interior.Color = 2551920
Target.Offset(0, 40).Interior.Color = vbYellow
Else
Range("AR6:AR" & son).Interior.Color = 15652797
Range("AS6:AS" & son).Interior.Color = 2551920
End If
End If
End Sub

 

[mustafa]

Üstteki mesajımı revize ettim. Son halini deneyiniz..

Bu ekte sunduğum dizi yöntemiyle sıra no vermektedir. Daha hızlı sonuç verebilir. Tek dezavantajı var olan filtreyi kaldırıp A sütunundaki yeni sıra numarası verdiği verileri filtrelemesidir. Yani sayfada uygulanan orjinal filtreleme kaybolmaktadır.

Kullanmak isteyebilirsiniz diye paylaşmak istedim.

Üstat bu dosya filtreleme yaptığımda sürekli donuyor, bu nedenle bir sonuç alamadım.

 

[Korhan Ayhan]

Benim paylaştığım dosyalarda deneme yaptığınızda bir sorun var mı?

 

[mustafa]

Üstat 8. mesajda verdiğiniz kodu dosyama uyguladığımda hata veriyordu. Fakat Option Explicit satırını eklemediğimde hata vermedi. Şu an kod sorunsuz çalışıyor.

Verdiğiniz emek için çok çok teşekkür ederim.

 

[Korhan Ayhan]

Bizler sizin asıl dosyalarınızdaki durumu bilemediğimiz için belirtmediğiniz sürece normal bir dosya mantığıyla çözümler sunuyoruz. Sonrasında benim dosyamda çalışmıyor ya da kendi dosyama kodu uyarlayamadım şeklinde dönüşler oluyor. Bu durumda belli bir süre sonra açıkçası cevap vermekten bizleri soğutuyor. Sürekli aynı konu üzerinde tekrar tekrar düşünüp çözüm üretmek için kıymetli vaktimizi harcıyoruz.

Bu tarz konu başlıklarında çözüm olarak sunulan formülü ya da makro kodunu dosyalarınıza uyarlama işlemleri kullanıcıya ait oluyor.

 

[mustafa]

Üstat, sitem ve eleştirinde haklısın, bundan sonra uyarılarını dikkate alacağım. Tekrar teşekkür ederim.