Şarta bağlı sutundaki verileri aktarma kod hızı hk.

[kemal turan]

Merhaba
aşağıdaki kod 5000 satırda yaklaşık 50-60 saniye de sonlanıyor.
Hızlandırmak mümkün mü,
Teşekkür ederim.

Sub fıyatdegıstır()

Set s2 = Sheets("ÜRÜNLER")
s2.AutoFilterMode = False
Dim a As Long
a = WorksheetFunction.CountIf(s2.Range("J16:J10000"), "SERİ SONU VEYA KOD HATALI")
If a > [0] Then
MsgBox "YENİ FİYAT LİSTESİNDE OLAN SERİ SONU VEYA KOD HATALI OLAN ÜRÜNLERİ KONTROL EDİNİZ." & vbLf & "BU SATIRLARI KOD DOĞRU İSE SERİ SONUNA ÇEVİRİNİZ"
SERISONU.Show
Exit Sub
End If
For i = 2 To s2.Range("a65536").End(xlUp).Row
SonSatir = s2.Range("a65536").End(xlUp).Row + 1

If s2.Cells(i, "J").Value <> 0 Then
s2.Cells(i, "G").Value = s2.Cells(i, "J").Value
s2.Cells(i, "H").Value = s2.Cells(i, "K").Value

End If
Next i
MsgBox "VERİLER ALINDI"
End Sub

 

[Muzaffer Ali]

Merhaba.,

Sub fıyatdegıstır()
    Dim S2 As Worksheet
    Dim a As Long
    Dim SonSatir As Long
    
    Set S2 = Sheets("ÜRÜNLER")
    S2.AutoFilterMode = False
    a = WorksheetFunction.CountIf(S2.Range("J16:J10000"), "SERİ SONU VEYA KOD HATALI")
    
    If a > [0] Then
        MsgBox "YENİ FİYAT LİSTESİNDE OLAN SERİ SONU VEYA KOD HATALI OLAN ÜRÜNLERİ KONTROL EDİNİZ." & vbLf & "BU SATIRLARI KOD DOĞRU İSE SERİ SONUNA ÇEVİRİNİZ"
        SERISONU.Show
        Exit Sub
    End If
    SonSatir = S2.Cells(Rows.Count, "J").End(xlUp).Row
    With S2.Range("G2:H" & SonSatir)
        .FormulaLocal = "=EĞER($J2<>0;J2;"""")"
        .Value
    End With
    MsgBox "VERİLER ALINDI"
End Sub

 

[kemal turan]

Muzaffer hocam merhaba,
1 saniye sürüyor .
Fakat J2 sıfır ise G2 VE H2 sutunlarındaki değerleri siliyor, silmemesi lazım.

 

[Muzaffer Ali]

Aşağıdaki kodu bir modüle kopyalayın. Sayfanın kod kısmına değil modüle kopyalayın. "FiyatDegistir" kodunu çalıştırın

Dim GH As Variant

Function STR(satır As Long, sutun As Long) As String
    STR = GH(satır, sutun)
End Function

Sub FiyatDegistir()
    Dim a As Long
    Dim SonSatir As Long
   
    With Sheets("ÜRÜNLER")
        .AutoFilterMode = False
        a = WorksheetFunction.CountIf(.Range("J16:J10000"), "SERİ SONU VEYA KOD HATALI")
       
        If a > [0] Then
            MsgBox "YENİ FİYAT LİSTESİNDE OLAN SERİ SONU VEYA KOD HATALI OLAN ÜRÜNLERİ KONTROL EDİNİZ." & vbLf & "BU SATIRLARI KOD DOĞRU İSE SERİ SONUNA ÇEVİRİNİZ"
            SERISONU.Show
            Exit Sub
        End If
        SonSatir = .Cells(Rows.Count, "J").End(xlUp).Row
        GH = .Range("G:H").Value
    End With
    With Sheets("ÜRÜNLER").Range("G2:H" & SonSatir)
        .FormulaLocal = "=EĞER($J2<>0;J2;str(Satır();Sütun()-6))"
        .Value = .Value
    End With
    MsgBox "VERİLER ALINDI"
End Sub

 

[kemal turan]

Muzaffer Hocam merhaba,
Yeni deneyebildim. Süper olmuş. Çok teşekkür ederim.
Selametle Kalınız.

 

[kemal turan]

Muzaffer Hocam merhaba,
Sonradan ihtiyaç oluştu kusura bakmayın.
Bu değişen satırlarda "I" sutun'una değişen kodun çalıştığı tarihi ekleyebilir miyiz.
İsteğim Özet olarak G:H değişen satırlarda "I" satırına fiyatın en son değiştiği tarihini eklemek
Teşekkür ederim.

 

[kemal turan]

Muzaffer Hocam
Verdiğiniz kodu kendime şu şekilde revize ettim. Kod1
Bir altdaki kod ile de en son sizden istediğim kodu sayfanın kod bölümünde yapmaya çalıştım. Kod 2
Bu kod da değişmemesi gereken satırlarda "YANLIŞ" a çeviriyor.
Modül de çalışan kodla olabilecek bir şey herhalde
Kod 2

Sub tarıhdegıstır()

Set S1 = Sheets("ÜRÜNLER")
Son = Cells(Rows.Count, "A").End(3).Row 'STOK KODU

With S1.Range("I16:I" & Son) 'GİREN
.Formula = "=IF(RC[1]<>0,NOW())"

End With
End Sub

Kod 1

Dim GH As Variant, GT As Date

Function STR(satır As Long, sutun As Long) As String
    STR = GH(satır, sutun)

   End Function

Sub FiyatDegistir()
    Dim a As Long
    Dim SonSatir As Long

    With Sheets("ÜRÜNLER")
        .AutoFilterMode = False
        a = WorksheetFunction.CountIf(.Range("J16:J10000"), "SERİ SONU VEYA KOD HATALI")
    
        If a > [0] Then
            MsgBox "YENİ FİYAT LİSTESİNDE OLAN SERİ SONU VEYA KOD HATALI OLAN ÜRÜNLERİ KONTROL EDİNİZ." & vbLf & "BU SATIRLARI KOD DOĞRU İSE SERİ SONUNA ÇEVİRİNİZ"
            SERISONU.Show
            Exit Sub
        End If
        SonSatir = .Cells(Rows.Count, "J").End(xlUp).Row
        GH = .Range("G:H").Value
      
    End With
    With Sheets("ÜRÜNLER").Range("G16:H" & SonSatir)
        .FormulaLocal = "=EĞER($J16<>0;J16;str(Satır();Sütun()-6))"
          '.Value = .Value
    End With
  
    MsgBox "VERİLER ALINDI"
End Sub

 

[kemal turan]

Arşiv çalışmalarımdan aşağıdaki kodu ayarladım.
yaklaşık 25 saniye sürüyor
Hızlandırabilir isek memnun olurum.
Teşekkür ederim

Sub tarıhdegıstır()

Set S1 = Sheets("ÜRÜNLER")

For k = 16 To S1.Cells(65536, "A").End(xlUp).Row
If S1.Cells(k, "J").Value > 0 Then
S1.Cells(k, "I").Value = Date
End If
Next k

End Sub

 

[Muzaffer Ali]

Aşağıdaki kodu deneyiniz.

Dim GH As Variant

Function STR(satır As Long, sutun As Long) As String
    STR = GH(satır, sutun)
End Function

Sub FiyatDegistir()
    Dim SonSatir As Long
    With Sheets("ÜRÜNLER")
        .AutoFilterMode = False
        If WorksheetFunction.CountIf(.Range("J16:J10000"), "SERİ SONU VEYA KOD HATALI") > [0] Then
            MsgBox "YENİ FİYAT LİSTESİNDE OLAN SERİ SONU VEYA KOD HATALI OLAN ÜRÜNLERİ KONTROL EDİNİZ." & vbLf & "BU SATIRLARI KOD DOĞRU İSE SERİ SONUNA ÇEVİRİNİZ"
            SERISONU.Show
            Exit Sub
        End If
        SonSatir = .Cells(Rows.Count, "J").End(xlUp).Row
        GH = .Range("G:H").Value
    End With
    With Sheets("ÜRÜNLER").Range("G2:H" & SonSatir)
        .FormulaLocal = "=EĞER($J2<>0;J2;str(Satır();Sütun()-6))"
        .Value = .Value
    End With
    GH = Sheets("ÜRÜNLER").Range("I:I").Value
    With Sheets("ÜRÜNLER").Range("I2:I" & SonSatir)
        .FormulaLocal = "=EĞER($J2<>0;""" & Date & """;str(Satır();1))"
        .Value = .Value
    End With
    MsgBox "VERİLER ALINDI"
End Sub

 

[kemal turan]

Muzaffer hocam merhaba,
Bilginize ve emeğinize sağlık. Süper oldu.
Hakkınızı helal ediniz.
Selametle kalınız