Kodun Yavaş Çalışması

[yanginci34]

Arkadaşlar merhaba;
Aşağıdaki kod ile Sayfa3 teki H sütunundaki veriler ve A sütunundaki veriler is_kalemleri sayfasındaki A sütunundaki verilerle eşleşirse is_kalemleri sayfasındaki B sütunundaki verilerle değiştiriliyor. Fakat kod çok yavaş çalışıyor bu yavaşlığı hızlandıracak, mevcut koda değişiklik veya başka bir yolu varmı ? Şimdiden teşekkürler.

Sub değiştir()
Dim son
Dim son2
Dim i
Dim j
son = Sheets("Sayfa3").Cells(Rows.Count, "h").End(3).Row
son2 = Sheets("is_kalemleri").Cells(Rows.Count, 1).End(3).Row
For i = 2 To son
For j = 1 To son2
If Sheets("Sayfa3").Cells(i, "h") = Sheets("is_kalemleri").Cells(j, 1) Then
   Sheets("Sayfa3").Cells(i, "h") = Sheets("is_kalemleri").Cells(j, 2)
   End If
   If Sheets("Sayfa3").Cells(i, "A") = Sheets("is_kalemleri").Cells(j, 1) Then
   Sheets("Sayfa3").Cells(i, "A") = Sheets("is_kalemleri").Cells(j, 2)
   End If
   Next
   Next
End Sub

 

[EmrExcel16]

Merhaba aşağıdaki kod ile deneyin.

Sub yeni_degistir()

    son = Sheets("is_kalemleri").Cells(Rows.Count, 1).End(3).Row   
    For i = 1 To son
        If Sheets("is_kalemleri").Cells(i, 1) <> "" Then       
            Set Rng = Range(Range("H2"), Range("H100000"))
            With Rng
                Set c = .Find(Sheets("is_kalemleri").Cells(i, 1), LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        Cells(c.Row, "H") = Sheets("is_kalemleri").Cells(i, 2)
                        Set c = .FindNext(c)
                        If c Is Nothing Then
                            GoTo Fin
                        End If
                    Loop While c.Address <> firstAddress
                End If
Fin:
            End With
            
            Set Rng2 = Range(Range("A2"), Range("A100000"))
            With Rng2
                Set d = .Find(Sheets("is_kalemleri").Cells(i, 1), LookIn:=xlValues)
                If Not d Is Nothing Then
                    firstAddress = d.Address
                    Do
                        Cells(d.Row, "A") = Sheets("is_kalemleri").Cells(i, 2)
                        Set d = .FindNext(d)
                        If d Is Nothing Then
                            GoTo Fine
                        End If
                    Loop While d.Address <> firstAddress
                End If
Fine:
            End With           
        End If
    Next
End Sub

 

[yanginci34]

Arkadaşım ilgin için çok teşekkür ederim kod çalışıyor fakat yavaşlık aynı malesef

 

[Ziynettin]

Kodu test edin.

Sub test()
Set s1 = Sheets("Sayfa3")
Set s2 = Sheets("is_kalemleri")
Set dic = CreateObject("scripting.dictionary")
son = s2.Cells(Rows.Count, "A").End(3).Row
a = s2.Range("A1:B" & son).Value
    For i = 1 To UBound(a)
        dic(a(i, 1)) = a(i, 2)
    Next i
son = s1.Cells(Rows.Count, "H").End(3).Row
a = s1.Range("H2:H" & son).Value
    For i = 1 To UBound(a)
        krt = a(i, 1)
        If dic.exists(krt) Then
            a(i, 1) = dic(krt)
        Else
            a(i, 1) = krt
        End If
    Next i
    s1.[H2].Resize(UBound(a), UBound(a, 2)).Value2 = a
    MsgBox "İşlem tamam.", vbInformation
End Sub

 

[yanginci34]

Kodu test edin.

Sub test()
Set s1 = Sheets("Sayfa3")
Set s2 = Sheets("is_kalemleri")
Set dic = CreateObject("scripting.dictionary")
son = s2.Cells(Rows.Count, "A").End(3).Row
a = s2.Range("A1:B" & son).Value
    For i = 1 To UBound(a)
        dic(a(i, 1)) = a(i, 2)
    Next i
son = s1.Cells(Rows.Count, "H").End(3).Row
a = s1.Range("H2:H" & son).Value
    For i = 1 To UBound(a)
        krt = a(i, 1)
        If dic.exists(krt) Then
            a(i, 1) = dic(krt)
        Else
            a(i, 1) = krt
        End If
    Next i
    s1.[H2].Resize(UBound(a), UBound(a, 2)).Value2 = a
    MsgBox "İşlem tamam.", vbInformation
End Sub

Teşekkür ederim sadece sayfa3 te H sütununda bulunanları değiştiriyor birde A sütununda olanları da değiştirte bilirmiyiz. Bu arada kod gayet hızlı tekrar teşekkürler.

 

[Ziynettin]

Sub test_2()
Set s1 = Sheets("Sayfa3")
Set s2 = Sheets("is_kalemleri")
Set dic = CreateObject("scripting.dictionary")
son = s2.Cells(Rows.Count, "A").End(3).Row
a = s2.Range("A1:B" & son).Value
    For i = 1 To UBound(a)
        dic(a(i, 1)) = a(i, 2)
    Next i
son = s1.Cells(Rows.Count, "H").End(3).Row
a = s1.Range("A2:H" & son).Value
ReDim w1(1 To UBound(a), 1 To 1)
ReDim w2(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt1 = a(i, 1)
        krt2 = a(i, 8)
        If dic.exists(krt1) Then w1(i, 1) = dic(krt1) Else w1(i, 1) = krt1
        If dic.exists(krt2) Then w2(i, 1) = dic(krt2) Else w2(i, 1) = krt2
    Next i
    s1.[A2].Resize(UBound(a)) = w1
    s1.[H2].Resize(UBound(a)) = w2
MsgBox "İşlem tamam.", vbInformation
End Sub