Çözüldü Hücre İçerisinde Belirtilen Koşula Göre Arama Yapma/Aktarma

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
58
Puanları
18
Yaş
31
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Merhaba;

Sayfa1' de yer alan [C] sütununda 1.500 adet veri bulunmaktadır. [C] sütununda yazılı 6 haneli rakamlar yer almakta ve bu rakamları Sayfa2 nin [D] sütunun hücrelerinin içerisinde aramasını ve bulması durumunda; [A] - ve [D] sütunundaki veriyi Sayfa3 yazdırmasını istiyorum. Konu hakkında yardımcı olabilir misiniz. Teşekkürler.

Sayfa1 C Sütunundaki hücrelerde 6 haneli rakamlarmevcuttur.
Sayfa2 D Sütununda ise 1 ile 9 hane rakamlarmevcuttur. 6 Haneli rakamlar baştan sona var ise aktarmalı


New Kriter.rar

Yaklaşık aranan satır sayısı 1.500 adet Sayfa1
Aranacak satır sayısı 50.000 - 75.000 adet Sayfa2
 

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
58
Puanları
18
Yaş
31
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Merhaba:

Aşağıdaki kod ile yapmak istediğim sorun çözülmüştür. İhtiyacı olabilecek arkadaşlar için paylaşıyorum.
Kod:
Option Explicit
Sub Bul_Aktar()
    Dim S1  As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Son_S1 As Long, Son_S2 As Long, Zaman As Double, Satir As Long
    Dim Veri As Variant, Aranan As Variant, X As Long, d As Object, krt
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    S3.Range("A2:A" & Rows.Count).Clear
    S3.Range("C2:C" & Rows.Count).Clear
    
    Son_S2 = S2.Cells(Rows.Count, 4).End(3).Row
    
    Veri = S2.Range("A2:E" & Son_S2).Value
    Son_S1 = S1.Cells(Rows.Count, 3).End(3).Row
    Aranan = S1.Range("C2:C" & Son_S1).Value
    
    Set d = CreateObject("scripting.dictionary")
    
    For X = 1 To UBound(Aranan)
        krt = CStr(Aranan(X, 1))
        d(krt) = krt
    Next X
    
    ReDim Liste(1 To UBound(Veri), 1 To 3)
    For X = 1 To UBound(Veri)
        krt = CStr(Left(Veri(X, 4), 6))
        If d.exists(krt) Then
            Satir = Satir + 1
            Liste(Satir, 1) = Veri(X, 1)
            Liste(Satir, 1) = Veri(X, 2)
            Liste(Satir, 3) = Veri(X, 4)
        End If
    Next X

    If Satir > 0 Then
        S3.Range("A2:C" & Rows.Count).NumberFormat = "@"
        S3.Range("A2:C" & Satir + 1).Value = Liste
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 

Admin

Yönetici
Site Yöneticisi
Katılım
25 May 2018
Mesajlar
1,095
Puanları
113
Konum
İstanbul
Web sitesi
www.excelarsivi.com
Ad Soyad
Excel Arşivi
Merhaba @gicimi,

Kısa bir not: Liste(Satir, 1) = Veri(X, 2 satırını Liste(Satir, 2) = Veri(X, 2) yaparsanız Birimini de almış olursunuz.

İlaveten, bu iki satırı neden ayrı ayrı yazdınız?
S3.Range("A2:A" & Rows.Count).Clear
S3.Range("C2:C" & Rows.Count).Clear
 

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
58
Puanları
18
Yaş
31
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Merhaba; @Admin

B sütununda da daha sonra başka işlem yapılacağını düşünerek öyle yazılmıştı.
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst Alt