Şartlı Veri Aktarma

[pasayor]

Herkese kolay gelsin,
Ekli dosyada veri aktarma ile ilgili bir sorum var. Yardımcı olursanız memnun olurum. Şimdiden teşekkürler

 

[İhsan Tank]

merhaba
sorunuzu biraz daha açarmısınız

 

[pasayor]

İhsan bey,
ilginize teşekkür ederim. Sorumu şöyle açıklayayım. 1. sayfada 50 ad. firmaya ait 100 tane fatura var. Ben bunlardan 2. sayfada yazılı olan sadece 20 firmaya ait fatura bilgilerini almak istiyorum ve bunu da 3. sayfaya tarih sırasına göre yazmak istiyorum. dosyanın içindeki örnekte olduğu gibi.

 

[Ömer]

Merhaba,

Fonksiyonlarla da yapılabilir fakat veri sayısı fazla olunca üstelik hem aktarım hem sıralama işlemi olacaksa dosyanızı kasabilir. Yinede fonksiyonla isterseniz belirtin o şekilde de yapmaya çalışırım.

Kodları module kopyalarak çalıştırın..

Option Explicit
 
Sub Olanı_Aktar()
 
Dim S1 As Worksheet, S2 As Worksheet, c As Range, ilkadres As Variant
Dim sat As Long, son1 As Long, son2 As Long, i As Long
 
Set S1 = Sheets("Sayfa1"): Set S2 = Sheets("Sayfa2")
 
Application.ScreenUpdating = False
 
Sheets("Sayfa3").Select
Range("C5:E65536").ClearContents
If S2.Range("C5") = "" Then Exit Sub
 
sat = 4
son1 = S1.[C65536].End(3).Row: son2 = S2.[C65536].End(3).Row
For i = 5 To son2
    Set c = S1.Range("C5:C" & son1).Find(S2.Cells(i, "C"), LookIn:=xlValues)
    If Not c Is Nothing Then
        ilkadres = c.Address
        Do
            sat = sat + 1
            Cells(sat, "C") = S1.Cells(c.Row, "B")
            Cells(sat, "D") = S1.Cells(c.Row, "C")
            Cells(sat, "E") = S1.Cells(c.Row, "D")
 
            Set c = S1.Range("C5:C" & son1).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> ilkadres
    End If
Next i
Range("C5:E65536").Sort Range("C5")
 
Application.ScreenUpdating = True
End Sub

 

[pasayor]

öemr bey,
çok teşekkür ederim, ellerinize sağlık.