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

[gicimi]

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 rakamlar mevcuttur.
Sayfa2 D Sütununda ise 1 ile 9 hane rakamlar mevcuttur. 6 Haneli rakamlar baştan sona var ise aktarmalı

Dosya 1.6 MB olmasından dolayı siteye eklenememiştir.

https://www.dosyaupload.com/r9pN

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

 

[Korhan Ayhan]

Eklediğiniz dosyaya erişemedim. Başka bir link verebilir misiniz?

 

[gicimi]

@Korhan Ayhan Bey link #1 mesajda güncelledim.

 

[Muzaffer Ali]

Merhaba.
Dosyanız ekte. İnceleyiniz.

https://www.dosyaupload.com/r9sL

Not: Dosya eklerken rar içine sıkıştırmadan, yalın hali ile eklerseniz daha iyi olur.
Rar ı açmak ile vakit kaybetmemiş oluruz.

 

[gicimi]

@dalgalikur Hocam elinize sağlık çok teşekkür ederim. “Form Aç” bastığımda Sayfa3 başlığını silinmemesi için ve Sayfa3 başlıklar hariç diğer satırları temizlemek için kod buton ekleyebilir miyiz.

 

[Muzaffer Ali]

Hata giderildi, buton eklendi.

https://www.dosyaupload.com/ez3B

 

[gicimi]

@dalgalikur hocam şu şekilde bir hata veriyor. Form Aç butonuna bastığımda.

If Checkbox1

Compile error:
Variable not defined

 

[Muzaffer Ali]

Formdaki bütün kodları silin aşağıdakileri kopyalayın.

Option Explicit

Private Sub CommandButton1_Click()
    Dim Bak As Range
    Dim Syf3Say As Long
    Dim Bul As Range
    Dim Say As Long
    Say = Sayfa1.Cells(Rows.Count, "C").End(3).Row
    ProgressBar1.Max = Say + 1
    If CheckBox1 Then Module1.Sayfa3Temizle
    For Each Bak In Sayfa1.Range("C2:C" & Say)
        ProgressBar1.Value = 1 + ProgressBar1.Value
        Label1.Caption = "Kalan = " & Say - ProgressBar1.Value
        For Each Bul In Sayfa2.Range("D2:D" & Sayfa2.Cells(Rows.Count, "D").End(3).Row)
            If Bul.Value Like "*" & Bak.Value & "*" Then
                Syf3Say = Sayfa3.Cells(Rows.Count, "A").End(3).Row + 1
                Sayfa3.Range("A" & Syf3Say).Value = Bul.Offset(0, -3).Value
                Sayfa3.Range("B" & Syf3Say).Value = Bul.Offset(0, -2).Value
                Sayfa3.Range("C" & Syf3Say).Value = Bul.Offset(0, 0).Value
            End If
        Next
    Next
    MsgBox "İşlem tammalandı", vbExclamation
End Sub

Private Sub UserForm_Initialize()
    CheckBox1.Value = True
End Sub

Module1 deki kodları silin aşağıdakileri kopyalayın.

Option Explicit

Sub Sayfa3Temizle()
    Dim Say As Long
    Say = Sayfa3.Cells(Rows.Count, "C").End(3).Row
    If Say > 1 Then Sayfa3.Range("A2:C" & Say).ClearContents
End Sub

 

[gicimi]

@dalgalikur hocam dediğiniz gibi yaptım yine aynı hata ile karşılaştım.

Compile error:
Variable not defined.

 

[Korhan Ayhan]

Alternatif;

1. Kod;

Bu kod yaklaşık 15 saniye civarında sonuçlanıyor.

Option Explicit

Sub Bul_Aktar_1()
    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, Y As Long
    
    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
    
    ReDim Liste(1 To Son_S2, 1 To 3)
    
    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
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = LBound(Aranan, 1) To UBound(Aranan, 1)
            If Val(Left(Veri(X, 4), 6)) = Aranan(Y, 1) Then
                Satir = Satir + 1
                ReDim Preserve Liste(1 To Son_S2, 1 To 3)
                Liste(Satir, 1) = Veri(X, 1)
                Liste(Satir, 3) = Veri(X, 4)
                Exit For
            End If
        Next
    Next
    
    S3.Range("A2:C" & Rows.Count).NumberFormat = "@"
    S3.Range("A2:C" & Satir + 1).Value = Liste
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub

2. Kod;

Bu kod ise yaklaşık 30 saniye civarında sonuç veriyor.

Option Explicit

Sub Bul_Aktar_2()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Son As Long, Zaman As Double, Satir As Long
    Dim Aranan As Variant, X As Long, Y As Long
    
    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 = S1.Cells(Rows.Count, 3).End(3).Row
    Aranan = S1.Range("C2:C" & Son).Value
    
    S2.Columns("D:D").TextToColumns Destination:=S2.Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 2), TrailingMinusNumbers:=True
    
    For X = LBound(Aranan, 1) To UBound(Aranan, 1)
        S2.Range("A1:E" & Rows.Count).AutoFilter Field:=4, Criteria1:=Aranan(X, 1) & "*"
        Son = S2.Cells(Rows.Count, 1).End(3).Row
        If Son > 1 Then
            Satir = S3.Cells(Rows.Count, 1).End(3).Row + 1
            S2.Range("A2:A" & Son).Copy S3.Cells(Satir, 1)
            S2.Range("D2:D" & Son).Copy S3.Cells(Satir, 3)
        End If
    Next
    
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub

 

[gicimi]

@Korhan Ayhan elinize sağlık hocam. Kodlar çalışıyor.

 

[Ziynettin]

Merhaba,

Korhan Beyin kodu üzerinden düzenleme yapılarak hızlandırılmış kod.

Option Explicit
Sub Bul_Aktar_3()
    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

 

[Muzaffer Ali]

@dalgalikur hocam dediğiniz gibi yaptım yine aynı hata ile karşılaştım.

Compile error:
Variable not defined.

Şimdi deneme yaptım ama bir hata almadım.
Hata mesajı çıktığında hangi satır sarı renk oluyor?

 

[gicimi]

@dalgalikur
Hata Görüntüsü

 

[gicimi]

@Ziynettin Hocam teşekkürler. Kodun çalışma süresi uçuyor. 0,06...

 

[Muzaffer Ali]

@dalgalikur
Hata Görüntüsü
Ekli dosyayı görüntüle 204934

Formda ProgressBar nesnesi mevcut anlaşılan sizin bilgisayarınızda bu kontrol olmadığından hata alıyorsunuz.
"ProgressBar1" geçen satırları silerseniz sorun kalmaz.

 

[gicimi]

Teşekkür ederim.