VBA Kod Hızlandırma

[askm]

Kolay gelsin.
Aşağıdaki kodlar ile Sıra numarası veriyorum ve Yazılan yazıyı büyük harfe çeviriyorum. 3000 Satır civarı veri var ve sürekli ekleme yapıyorum. Kod yavaş çalışıyor. Nasıl hızlandırabilirim. Bildiğim hızlandırma kodlarını da denedim ama yine de yavaş.Teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next

If Intersect(Target, Range("b2:b10000")) Is Nothing Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If Target = "" Then Exit Sub

ssn = Application.WorksheetFunction.Max(Range("a2" & ":" & "a" & Target.Row - 1))
Target.Value = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
Target.Offset(0, -1) = ssn + 1

If Target.Offset(0, -1) Mod 2 = 0 Then
ThisWorkbook.Save

End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

End Sub

 

[Necdet]

Merhaba,

Basit bir kaç satırlık veri ile birlikte dosya ekleseniz yardım almanız daha da hızlanırdı.

sadece kodlara bakarak anlamak zor.

 

[askm]

Örnek ektedir.

 

[GAZOZ_55]

Kolay gelsin.
Aşağıdaki kodlar ile Sıra numarası veriyorum ve Yazılan yazıyı büyük harfe çeviriyorum. 3000 Satır civarı veri var ve sürekli ekleme yapıyorum. Kod yavaş çalışıyor. Nasıl hızlandırabilirim. Bildiğim hızlandırma kodlarını da denedim ama yine de yavaş.Teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next

If Intersect(Target, Range("b2:b10000")) Is Nothing Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If Target = "" Then Exit Sub

ssn = Application.WorksheetFunction.Max(Range("a2" & ":" & "a" & Target.Row - 1))
Target.Value = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
Target.Offset(0, -1) = ssn + 1

If Target.Offset(0, -1) Mod 2 = 0 Then
ThisWorkbook.Save

End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

End Sub

Kod işime yaradı, sağ olasın.

 

[Korhan Ayhan]

@askm,

Hücresel bazda işlem yapmasını istediğiniz için ve renklendirme yapılması talep ettiğiniz için hız konusunda pek yol alacağınızı düşünmüyorum.

Karakter renklenmesi yerine hücre renklenmesi derseniz o olabilir.

 

[Korhan Ayhan]

Çok afedersiniz...

Ben mesaj yazılınca yardım talep edildiğini düşündüm. Eski bir konuymuş.

 

[Korhan Ayhan]

Rahat duramadım...

Biraz kaçamak yollara başvurarak kodun hızlı çalışmasını sağladım.

Aranan veri hücresel bazda renkleniyor. Bu sebeple oldukça hızlandı.

A sütununa sıra numarası veriyor.
B sütunu büyük harfe dönüşüyor.
B1 hücresine yazılan değere göre (içerir mantığı ile) filtreleme yapılıyor ve eğer aranan değer varsa hücreler renkleniyor.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Son As Long, Veri As Range, Alan As Range
    
    On Error GoTo 10
    
    Application.ScreenUpdating = 0
    Application.EnableEvents = 0
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    If Not Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then
        Son = Cells.Find("*", SearchDirection:=xlPrevious).Row
        
        For Each Veri In Target.Cells(1, 1)
            With Range("A3:A" & Son)
                .Formula = "=ROW(A1)"
                .Value = .Value
            End With
        
            With Range("AA3:AA" & Son)
                .Formula = "=UPPER(B3)"
                .Value = .Value
                 Range("B3:B" & Son).Value = .Value
                .ClearContents
            End With
        Next
    
    ElseIf Not Intersect(Target, Range("B1")) Is Nothing Then
        Range("B3:B" & Rows.Count).Interior.ColorIndex = -4142
        If Target <> "" Then
            Range("A2:C" & Rows.Count).AutoFilter 2, "*" & Target & "*"
            Son = Cells(Rows.Count, 2).End(3).Row
            If Son > 2 Then
                Set Alan = Range("B3:B" & Son).SpecialCells(xlCellTypeVisible)
                If Not Alan Is Nothing Then Alan.Interior.ColorIndex = 37
            End If
        End If
    End If

10
    Application.EnableEvents = 1
    Application.ScreenUpdating = 1
End Sub