Sadece Vba Kodunu Hızlandırmak

[Kemter]

Merhaba arkadaşlar
11.600 satırlık veriyi sayfalara 15 dakika da aktırıyor.
Bunu daha hızlı aktramak için başka bir kod için yardımcı olabilir misiniz?
Sayfa1 deki Sicil No (B) Sutünü ile Cinsiyet (D) sutündaki verileri Sheet1, Sheet2...ve Sheet11 deki (B) sutündaki sicil göre bulup, (I) sutüna ERKEK ve KADIN diye aktarmasını sağlamak.
Saygılarımla.

 

[N.Ziya Hiçdurmaz]

Merhaba; Bu şekil denermisiniz.

Private Sub CommandButton1_Click()
Dim i As Byte
Dim satv As Integer
Dim satk As Integer
Dim dicv As Object
basla = Timer
v = Sayfa10.Range("b1:e" & Sayfa10.Cells(Rows.Count, "b").End(xlUp).Row)
For i = 2 To Sheets.Count
k = Sheets(i).Range("b1:I" & Sheets(i).Cells(Rows.Count, "b").End(xlUp).Row)
Set dicv = CreateObject("scripting.dictionary")
For satv = 2 To UBound(v)
dicv(v(satv, 1)) = satv
Next
For satk = 7 To UBound(k)
If dicv.exists(k(satk, 1)) Then
Sheets(i).Cells(satk, "I") = v(dicv(k(satk, 1)), 3)
End If
Next
Next
bitir = Timer
MsgBox "Süre " & Format(bitir - basla, "0.0")
End Sub

 

[Korhan Ayhan]

Alternatif;

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, WS As Worksheet, My_Array As Object
    Dim My_Data As Variant, My_Sh_Data As Variant
    Dim No As Long, X As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data = S1.Range("A2:E" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        My_Array.Item(My_Data(X, 2)) = My_Data(X, 4)
    Next
    
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> "Sayfa1" Then
            WS.Range("I:I").ClearContents
            My_Sh_Data = WS.Range("B7:B" & WS.Cells(WS.Rows.Count, 1).End(3).Row).Value
            ReDim My_List(1 To WS.Cells(WS.Rows.Count, 1).End(3).Row, 1 To 1)
            For X = LBound(My_Sh_Data, 1) To UBound(My_Sh_Data, 1)
                No = No + 1
                If My_Array.Exists(My_Sh_Data(X, 1)) Then
                    My_List(No, 1) = My_Array.Item(My_Sh_Data(X, 1))
                End If
            Next
            WS.Range("I7").Resize(No) = My_List
            No = 0
        End If
    Next

    Erase My_List

    Set S1 = Nothing
    Set My_Array = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[Kemter]

Merhaba; Bu şekil denermisiniz.

Private Sub CommandButton1_Click()
Dim i As Byte
Dim satv As Integer
Dim satk As Integer
Dim dicv As Object
basla = Timer
v = Sayfa10.Range("b1:e" & Sayfa10.Cells(Rows.Count, "b").End(xlUp).Row)
For i = 2 To Sheets.Count
k = Sheets(i).Range("b1:I" & Sheets(i).Cells(Rows.Count, "b").End(xlUp).Row)
Set dicv = CreateObject("scripting.dictionary")
For satv = 2 To UBound(v)
dicv(v(satv, 1)) = satv
Next
For satk = 7 To UBound(k)
If dicv.exists(k(satk, 1)) Then
Sheets(i).Cells(satk, "I") = v(dicv(k(satk, 1)), 3)
End If
Next
Next
bitir = Timer
MsgBox "Süre " & Format(bitir - basla, "0.0")
End Sub

Sayın N.Ziya HİÇDURMAZ Bey
Emeğinize bilginize sağlık önceki kod da ve şimdiki kod da çalışıyor.
Hayırlı günler dilerim.

 

[Kemter]

Alternatif;

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, WS As Worksheet, My_Array As Object
    Dim My_Data As Variant, My_Sh_Data As Variant
    Dim No As Long, X As Long, Process_Time As Double
  
    Process_Time = Timer
  
    Application.ScreenUpdating = False
  
    Set S1 = Sheets("Sayfa1")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
  
    My_Data = S1.Range("A2:E" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
  
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        My_Array.Item(My_Data(X, 2)) = My_Data(X, 4)
    Next
  
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> "Sayfa1" Then
            WS.Range("I:I").ClearContents
            My_Sh_Data = WS.Range("B7:B" & WS.Cells(WS.Rows.Count, 1).End(3).Row).Value
            ReDim My_List(1 To WS.Cells(WS.Rows.Count, 1).End(3).Row, 1 To 1)
            For X = LBound(My_Sh_Data, 1) To UBound(My_Sh_Data, 1)
                No = No + 1
                If My_Array.Exists(My_Sh_Data(X, 1)) Then
                    My_List(No, 1) = My_Array.Item(My_Sh_Data(X, 1))
                End If
            Next
            WS.Range("I7").Resize(No) = My_List
            No = 0
        End If
    Next

    Erase My_List

    Set S1 = Nothing
    Set My_Array = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

Sayın Korhan AYHAN Bey
Emeğinize bilginize sağlık kod ekdeki dosyamda çalışıyor fakat asıl dosyamda ise Run-time error '1004' veriyor oda
WS.Range("I:I").ClearContents satırında oluyor, bu satırı iptal ettiğim zaman kod çalışıyor.
Hayırlı günler dilerim.