Artı - eksi koşullu veri çekmek

[honestman]

Merhaba,

Sheet 1 de C sütunundaki poliçe numaraları, sheet 2 deki A sütunuyla karşılaştırılsın Aynı zamanda Sheet 1 deki B sutunu ve sheet 2 deki C sutunundaki tarihler karşılaştırılıp. poliçe numaraları aynı olup tarihleri eşit yada en fazla artı yada eksi 5 gün olanların claim numarasını sayfa 3 te görmek istiyorum. Datayı küçültmek için birazını sildim.Dosya ektedir. Yardımınızı rica ederim.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub BulYaz()
 
    Dim S1 As Worksheet, S2 As Worksheet, i as Long
    Dim sat As Long, c As Range, Adr As String
 
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    Sheets("Sheet3").Select
    Range("A2:A" & Rows.Count).ClearContents
 
    sat = 2
    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        Set c = S2.[A:A].Find(S1.Cells(i, "C"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If Abs(S2.Cells(c.Row, "C") - S1.Cells(i, "B")) < 6 Then
                    Cells(sat, "A") = S1.Cells(i, "A")
                    sat = sat + 1
                End If
                Set c = S2.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
 
End Sub

.

 

[honestman]

Merhaba Ömer bey,


Karşılaştırma yapıp istenilen şartları karşılayanların Claim _numaralarını 3. sayfaya vereceğine sayfa2 deki poliçe numaralarını siliyor. Yardımınızı rica ederim.

 

[Ömer]

Tekrar denedim herhangi bir sorun olmadan çalıştı.

Kodlarda Sayfa2 deki verileri silecek yada üzerine yazacak bir satır da yoktur. İstediğiniz gibi sadece Sayfa3 e şarta uyan "CLAIM_NUM" ları yazmaktadır.

 

[honestman]

Tekrar denedim ama sheet 2 deki a sütunundaki verileri sildi sadece...Size zahmet çalışmış halini upload edebilir misiniz? Sayfa 3 e sonuç vermiş halini...

 

[Ömer]

Siz denedikten sonraki halini eklermisiniz.

 

[honestman]

Ektedir, teşekkürler..

 

[Ömer]

Kodu modul için yazmıştım, siz sayfada kullanmışsınız. Bu yüzden hata aldınız.

Bu şekilde deneyin.

Private Sub CommandButton1_Click()
 
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim sat As Long, c As Range, Adr As String, i As Long
 
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    Set S3 = Sheets("Sheet3")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    S3.Range("A2:A" & Rows.Count).ClearContents
 
    sat = 2
    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        Set c = S2.[A:A].Find(S1.Cells(i, "C"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If Abs(S2.Cells(c.Row, "C") - S1.Cells(i, "B")) < 6 Then
                    S3.Cells(sat, "A") = S1.Cells(i, "A")
                    sat = sat + 1
                End If
                Set c = S2.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
 
End Sub

.

 

[honestman]

Çok teşekkür ederim...

 

[honestman]

Merhaba,


Çok fazla veri olduğundan bilgisayarı donduruyor. Bir çözüm önerebilir misiniz?

 

[Ömer]

Büyük datalarda istediğiniz işlem için bekleme süresinin uzaması normaldir.
Tahmini data satır sayısı nedir?
Sayfa2 deki veriler Sayfa1 den daha az mı oluyor? Yoksa kimi zaman az kimi zaman fazla mı oluyor, yada hemen hemen iki sayfadaki veriler de aynı boyutta mı?
Eğer birinin birinden azlık oranı arasında fark varsa döngüyü kurduğumuz sayfayı değiştirerek ilerleyebiliriz.

 

[honestman]

Sayfa 1 deki veriler hep daha fazla oluyor sayfa 2 den. Dögü doğru çalışıyor. Ortasında durdurup test etmiştim Sadece hız problemi var... Do events ekledim ama değişen birşey olmadı. Yardım rica ederim.

 

[Ömer]

Bu şekilde deneyin.

Döngüyü sayfa2 ye göre kurdum, ayrıca yazma işini döngü sonuna bıraktım bu şekilde daha hızlı olacaktır. Yazdığınız doevents'ide ekledim.

Donma işlemine takılmadan sonuçları almak için beklemenizi tavsiye ederim. Bu haliyle ilk eklediğiniz dosyaya göre 7-8 dakika arası bir zamanda işlem sonuçlandı.

Private Sub CommandButton1_Click()
 
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim sat As Long, c As Range, Adr As String, i As Long, Dizi()
    Dim BsSure As Date, BtSure As Date, IslemSuresi As Date
 
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    Set S3 = Sheets("Sheet3")
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    BsSure = Time
    S3.Range("A2:A" & Rows.Count).ClearContents
 
    For i = 2 To S2.Cells(Rows.Count, "A").End(xlUp).Row
        Set c = S1.[C:C].Find(S2.Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                DoEvents
                If Abs(S1.Cells(c.Row, "B") - S2.Cells(i, "C")) < 6 Then
                    ReDim Preserve Dizi(0 To sat)
                    Dizi(sat) = S1.Cells(c.Row, "A")
                    sat = sat + 1
                End If
                Set c = S1.[C:C].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
 
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
 
    S3.Range("A2").Resize(UBound(Dizi) + 1, 1) = _
                Application.WorksheetFunction.Transpose(Dizi)
    BtSure = Time: IslemSuresi = BtSure - BsSure
    MsgBox "Çalışma Süresi : " & Format(IslemSuresi, "hh:mm:ss:dd")
 
End Sub

.

 

[honestman]

Deneyeceğim. Teşekkür ederim.