Soru Sıralama sırasında kasma.

[yasarcan]

17000 satırlık bir veritabanım var. Bunlardan bazı satırları gizleyerek bazı sütunlara göre büyükten küçüğe sıralama yapıyorum.
yine bir butonla orjinal küçükten büyüğe verdiğim sıra numarasına göre orjinal hale geri getiriyorum

sorum şu:
orjinal sıra numarası verdiğimde 1 den 17000 e; vba larım müthiş kasıyor. nasıl bir yöntem uygulamalıyım?

 

[Korhan Ayhan]

Siz hangi yöntemi kullanıyorsunuz?

 

[yasarcan]

hocam şöyle:
a sütunu boş
b sütununda puan var
c sütununda 1-den 17000 e sıralama var.

vba ile büyükten küçüğe (b deki puana göre sıralıyorum)
vba ile a sütununa sıra numarası veriyorum çıktı alıyorum
a sütunu siliyorum makroyla.
vba ile küçükten büyüğe ( buradaki değer orjinale dönmesi için sabit) sıralayarak ilk hale dönerek çıkıyorum.

burada hiçbir sorun yok. başka bir sayfada satır gizleme vba sı var. oda güzel çalışıyor.
fakat c sütununda 1 den 17000 e sabit numara yazınca inanılmaz kasıyor. boş bırakırsam çok hızlı çalışıyor.

 

[Korhan Ayhan]

Bende kasma durumunda kullandığınız yapıyı soruyorum. O bölümde hangi kodu kullanıyorsunuz?

 

[yasarcan]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sayfalar
    Dim DahilBak As Integer
    Dim Dahil As Boolean
    Dim syf As Worksheet
    Dim Temizle As Boolean
    Sayfalar = Array("ANASAYFA") 
    Application.EnableEvents = False
    If Target.Text = "a" Then
        Cells(Target.Row, 3) = ""
        Cells(Target.Row, 4) = ""
        Cells(Target.Row, 5) = ""
        Cells(Target.Row, Target.Column) = "a"
    ElseIf Target.Text = "" Then
        Temizle = True
    End If
    For Each syf In ThisWorkbook.Worksheets

        Dahil = False
        For DahilBak = 0 To UBound(Sayfalar)
            If syf.Name = Sayfalar(DahilBak) Then
                Dahil = True
                Exit For
            End If
        Next
        If Dahil = True Then
            If Not Intersect(Target, Range("C:E", "H:H")) Is Nothing Then
                Select Case Target.Column
                    Case 3 'Evet
                        syf.Rows((Target.Row * 2) + 7).EntireRow.Hidden = True
                        syf.Rows((Target.Row * 2) + 8).EntireRow.Hidden = False
                    Case 4 'Hayır
                        syf.Rows((Target.Row * 2) + 7).EntireRow.Hidden = False
                        syf.Rows((Target.Row * 2) + 8).EntireRow.Hidden = True
                    
                    Case 5 ' Uygulanamaz
                        syf.Rows((Target.Row * 2) + 7).EntireRow.Hidden = True
                        syf.Rows((Target.Row * 2) + 8).EntireRow.Hidden = True
                    
                End Select
                
                If Temizle Then
                    syf.Rows((Target.Row * 2) + 7).EntireRow.Hidden = False
                    syf.Rows((Target.Row * 2) + 8).EntireRow.Hidden = False
                End If
            End If
        End If
    Next
    Application.EnableEvents = True
End Sub

 

[yasarcan]

Hocam kodun dışında bir kolona sabit numara vermeyi denicem.

denedim olmadı zaten kod tüm satırlarda çalıştığı için dışınada çıkamadım.

 

[Korhan Ayhan]

Ben sizden sıra numarası veren kod bloğunu istemiştim. Neyse anlaşamadık.

Aşağıdaki kod tek hamlede koşulsuz olarak A1:A20000 hücrelerine sıra numarası verir.

Eğer aradığınız bu değilse örnek dosya ekleyerek yapmak istediğiniz işlemi açıklayınız.

Option Explicit

Sub Sira_No()
    Range("A1:A20000") = Evaluate("ROW(A1:A20000)")
End Sub

 

[yasarcan]

sıra

Ben sizden sıra numarası veren kod bloğunu istemiştim. Neyse anlaşamadık.

Aşağıdaki kod tek hamlede koşulsuz olarak A1:A20000 hücrelerine sıra numarası verir.

Eğer aradığınız bu değilse örnek dosya ekleyerek yapmak istediğiniz işlemi açıklayınız.

Option Explicit

Sub Sira_No()
    Range("A1:A20000") = Evaluate("ROW(A1:A20000)")
End Sub

c numarasını elle giriyorum hocam.
a daki numarayıda

Private Sub CommandButton3_Click()
Dim i As Long, x As Long
For i = 11 To Range("B65536").End(3).Row
On Error Resume Next
If (Range("b" & i).Value <> "") And Rows(i).RowHeight > 0 Then
Cells(Rows(i).Row, "A").Value = x + 1
x = x + 1
End If
Next i
x = Empty
End Sub

bununla veriyorum. numara verirken kasma yok.
diğer sayfadaki kodu mumaralar üzerindeyken çalıştırınca kasma oluyo
numaralar yokken sütunlar boşken kasma yok.

verdiğiniz kodu deniyeyim

 

[reosman]

Option Explicit

Sub Sira_No()
Range("A1:A20000") = Evaluate("ROW(A1:A20000)")
End Sub

Hocam bu kodu son dolu satıra kadar ver nasıl yaparız ?

 

[FERAZ]

Evaluate("ROW(A1:A" & son & ")")

 

[reosman]

Maalesef olmadı

 

[Seyit Tiken]

Bence soru eksik sorulmuş.

 

[reosman]

Bence soru eksik sorulmuş.

Sub Sira_No()
Range("A1:A20000") = Evaluate("ROW(A1:A20000)")
End Sub

Seyit hocam, B sütununun son dolu hücresine kadar A2'den itibaren sıra
numarası vermek istiyorum.

 

[Seyit Tiken]

Bu şekilde deneyiniz.

Sub SıraNo()
With Range("A1:A" & Cells(Rows.Count, "B").End(3).Row)
.Formula = "=Row()"
.Value = .Value
End With
End Sub

 

[Seyit Tiken]

Kod Günceleme :

Sub SıraNo()
For h = 1 To Cells(Rows.Count, "A").End(3).Row
Cells(h, "A") = ""
Next
With Range("A1:A" & Cells(Rows.Count, "B").End(3).Row)
.Formula = "=Row()"
.Value = .Value
End With
End Sub

 

[FERAZ]

Maalesef olmadı

Olmamasının sebebi son diye değişken tanımlayıp son = ........ ile bulunmalı son satır.Son satır bulma her yerde var kolayca.