• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kodda düzenleme yapmak

T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,181
Excel Vers. ve Dili
Ofis 2019 Türkçe
Kod: 
Sub ArraytoDict()
    Dim timer0 As Single
    Dim kaynak As Worksheet
    Dim hedef As Worksheet
    Dim myArray() As Variant
    Dim dict As Object
    Dim i As Long
    timer0 = Timer()
    Application.ScreenUpdating = False

    Set kaynak = ThisWorkbook.Worksheets("data")
    Set hedef = ThisWorkbook.Worksheets("tc_sicil")
    hedef.Range("B3:F" & Rows.Count).ClearContents
    myArray = kaynak.Range("A2:F" & kaynak.Cells(kaynak.Rows.Count, "A").End(xlUp).Row).Value
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(myArray, 1)
        dict(myArray(i, 1)) = myArray(i, 2)
    Next
   
    Dim cell As Range
    hedef.Select
    Range("A2:A" & hedef.Cells(hedef.Rows.Count, "A").End(xlUp).Row).Select
    For Each cell In Selection
        cell.Offset(0, 1) = dict(cell.Value)
    Next cell
    Set dict = Nothing
    Range("B2").Select
    Application.ScreenUpdating = True

    MsgBox "İşleminiz " & Timer - timer0 & " saniyede tamamlanmıştır."
End Sub

Bu kod ile 100000 Bin satırlarda bule 0,68 sn. gibi çok kısa bir zamanda data sayfasından arama yaptığım tc_sicil sayfasındaki A sutununda aradığım TC karşılıklarının data sayfasındaki B sutununda bulunan sicil karşılıklarını alabiliyorum.

Benim istediğim C,D,E,F vs. sutunlarınıda almak istersem kodda nasıl bir revize yapmalıyım, çok denemeler yaptım ancak başarılı olamadım. Yardımcı olabilecek hocalarıma şimdiden teşekkür ederim.
Saygılar
 

Ekli dosyalar

Diğer başlıkta sorduğunuz sorunuzun benzeri gibi görünüyor. Aynı kodu kullanabilirsiniz.
 
@Korhan Ayhan hocam doğrudur, ben bu konuyu araştırırken bulduğum kodları anlamaya çalıştığımdan bu konuyu açtım, tek sutun değilde birden fazla sutun getirmek istersek bu kodda nasıl bir değişiklik yapılmalı onu öğrenmeye çalışıyorum. Teşekkürler
 
Diğer başlıkta ilk döngü içinde ARRAY olarak yazılan bölümde aktarılmaktadır istenen sütunlara ait veriler hafızaya alınmaktadır. O bölümle oynayarak geliştirebilirsiniz.

Sonrasında ikinci döngü içinde bunları parçalayarak ayrıştırmalısınız.
 
Kodları aşağıdaki şekilde deneyebilirsiniz.
Kod: 
Sub Listele2()
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
   
    Zaman = Timer

    Set S1 = Sheets("data")
    Set S2 = Sheets("tc_sicil")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
  
    Veri = S1.Range("A3:F" & Son).Value
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Dizi.Add Veri(X, 1), Array(Veri(X, 2), Veri(X, 3), Veri(X, 4), Veri(X, 5), Veri(X, 6))
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row

    Veri = S2.Range("A3:A" & Son).Value
  
    ReDim Liste(1 To Son - 1, 1 To 6)
      
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))(0)
            Liste(Say, 3) = Dizi.Item(Veri(X, 1))(1)
            Liste(Say, 4) = Dizi.Item(Veri(X, 1))(2)
            Liste(Say, 5) = Dizi.Item(Veri(X, 1))(3)
            Liste(Say, 6) = Dizi.Item(Veri(X, 1))(4)
        Else
            Liste(Say, 1) = Veri(X, 1)
        End If
    Next
  
    S2.Range("A3:f" & S2.Rows.Count).ClearContents
  
    If Say > 0 Then S2.Range("A3").Resize(Say, 6) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Aşağıdaki şekilde deneyin.
Kod: 
Sub ArraytoDict()
    Dim timer0 As Single
    Dim kaynak As Worksheet
    Dim hedef As Worksheet
    Dim myArray() As Variant
    Dim dict As Object
    Dim i As Long
    timer0 = Timer()
    Application.ScreenUpdating = False

    Set kaynak = ThisWorkbook.Worksheets("data")
    Set hedef = ThisWorkbook.Worksheets("tc_sicil")
    hedef.Range("B3:F" & Rows.Count).ClearContents
    myArray = kaynak.Range("A2:F" & kaynak.Cells(kaynak.Rows.Count, "A").End(xlUp).Row).Value
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(myArray, 1)
        dict(myArray(i, 1)) = myArray(i, 1) & "#" & myArray(i, 2) & "#" & myArray(i, 3) & "#" & myArray(i, 4) & "#" & myArray(i, 5) & "#" & myArray(i, 6)
    Next
    
    Dim cell As Range
    hedef.Select
    Range("A3:A" & hedef.Cells(hedef.Rows.Count, "A").End(xlUp).Row).Select
    For Each cell In Selection
        Data = dict(cell.Value)
        For y = 0 To 5
            cell.Offset(0, y) = Split(Data, "#")(y)
        Next y
    Next cell
    Set dict = Nothing
    Range("B2").Select
    Application.ScreenUpdating = True

    MsgBox "İşleminiz " & Timer - timer0 & " saniyede tamamlanmıştır."
End Sub
 
İlk yöntem 0,56 sn.
İkinci yöntem ile de 0,88 sn sürdü işlem.
 
Sn. @askm İlginiz için çok teşekkür ediyorum, 170000 satırda denedim 50 sn. sürdü, aynı datata 5.mesajınızdaki kod 18 sn. sürüyor, sanırım önceki kodu kullanmak daha iyi olacak. Teşekkürler.
 
Aynı veriye göre deneyiniz.

Kod: 
Sub test()
    Dim dc As Object
    Dim i As Long
    sure = TimeValue(Now)
    Application.ScreenUpdating = False

    Set S1 = ThisWorkbook.Worksheets("data")
    Set S2 = ThisWorkbook.Worksheets("tc_sicil")
    S2.Range("B3:F" & Rows.Count).ClearContents
    a = S1.Range("A2:F" & S1.Cells(Rows.Count, "A").End(xlUp).Row).Value
    Set dc = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(a)
        dc(CStr(a(i, 1))) = i
    Next
    
    b = S2.Range("A2:A" & S2.Cells(Rows.Count, "A").End(xlUp).Row).Value
    ReDim c(1 To UBound(b), 1 To 5)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If dc.Exists(krt) Then
            For j = 2 To 6
                c(i, j - 1) = a(dc(krt), j)
            Next j
        End If
    Next i
    Set dc = Nothing
    Range("B2").Select
    [B2].Resize(UBound(b), 5) = c
    Application.ScreenUpdating = True

    MsgBox "İşleminiz " & CDate(TimeValue(Now) - sure) & " saniyede tamamlanmıştır."
End Sub
 
Sn. @Ziynettin Bey, 170000 satırda denedim 00:00:03 sn. sürdü, 1000000 satırda denetim 00:00:15 sn. Müthiş hızlı elinize sağlık. Çok teşekkür ediyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst