Makro İle Çoklu Veri Alma

[topcuexcel]

Merhabalar
Üretim Sonuçlarını karışık girdiğim bir sayfadan İş Emri Numarası ile bir başka sayfaya rapor çekmek istiyorum. Farklı satırlarda birden fazla aynı İş Emri No'su var.
Aşağıdaki makroya göre raporu çektiğimde örneğin aynı iş emri 6 farklı satırda varsa doğru yerlere 6 satırda bilgi alabiliyorum ama hepsi aynı bilgiden oluşuyor.
Hatamın farkındayım yazdığım makroya göre i değişkeni ilk İş Emri No'sunun bulunduğu satır numarasına alıyor. İş Emri No'sunun bulunduğu diğer satırları makronun içine bir türlü dahil edemedim yardımcı olabilirseniz çok sevinirim.

Private Sub CommandButton2_Click()
Dim k As Integer
Set S1 = Sheets("DATA")
Set S2 = Sheets("Uretım Adet Sorgulama")
SONSAT = S1.Range("D65536").End(3).Row
SAY = WorksheetFunction.CountIf(S1.Range("D2:D" & SONSAT), TextBox3.Value)
If SAY = 0 Then Exit Sub
Aranan = TextBox3.Value ' İş Emri No
i = S1.Range("D2:D" & SONSAT).Find(what:=Aranan, lookat:=xlWhole).Row ' ilgili İş Emri No Satırı
For k = 1 To SAY
S2.Cells(1 + k, 1) = S1.Cells(i, 4) 'İş Emri No
S2.Cells(1 + k, 4) = S1.Cells(i, 2) 'Stok Kodu
S2.Cells(1 + k, 2) = S1.Cells(i, 8) 'Stok Adı
S2.Cells(1 + k, 3) = S1.Cells(i, 7) 'Bölüm
S2.Cells(1 + k, 5) = S1.Cells(i, 3) 'Makina
S2.Cells(1 + k, 6) = S1.Cells(i, 11) 'Tarih
S2.Cells(1 + k, 7) = S1.Cells(i, 26) 'Miktar
Next k
UserForm5.Hide
UserForm2.Hide
S2.Select
End Sub

 

[dEdE]

Merhaba,
Aşağıdaki şekilde dener misiniz?

Private Sub CommandButton2_Click()
Dim k As Integer
Set s1 = Sheets("DATA")
Set s2 = Sheets("Uretım Adet Sorgulama")
Aranan = TextBox3.Value ' İş Emri No
Set Bulunan = s1.Range("D:D").Find(Aranan, , xlValues, xlWhole)
    If Not Bulunan Is Nothing Then
        adres = Bulunan.Address
        Do
            ss = s2.Range("A" & Rows.Count).End(3).Row + 1
            s2.Cells(ss, 1) = s1.Cells(Bulunan.Row, 4) 'İş Emri No
            s2.Cells(ss, 4) = s1.Cells(Bulunan.Row, 2) 'Stok Kodu
            s2.Cells(ss, 2) = s1.Cells(Bulunan.Row, 8) 'Stok Adı
            s2.Cells(ss, 3) = s1.Cells(Bulunan.Row, 7) 'Bölüm
            s2.Cells(ss, 5) = s1.Cells(Bulunan.Row, 3) 'Makina
            s2.Cells(ss, 6) = s1.Cells(Bulunan.Row, 11) 'Tarih
            s2.Cells(ss, 7) = s1.Cells(Bulunan.Row, 26) 'Miktar
            Set Bulunan = s1.Range("D:D").FindNext(Bulunan)
        Loop While Not Bulunan Is Nothing And Bulunan.Address <> adres
    End If
UserForm5.Hide
UserForm2.Hide
s2.Select
End Sub

 

[topcuexcel]

Teşekkürler...
Elinize Sağlık..