sheetler arasındaki veriyi karsılastırıp listelemek

[kayra75]

Merhaba sheet1 de kırtasiye malzemeleri bulunmakta sheet 2 de hangi hoca hangi malzemeyi aldığı yazılı sheet 3 de de bu hocanın almıs oldugu kırtasiyeyi sıralamam lazım bu konuda yardım rica ediyorum arkadaslar.
elimde 100 hoca var ve listeyi scan edebildim ve excele aktarabildim.ama tek tek kopyala yapıstır yapmak zorunda mıyım yoksa kolayı varmıdır.Dosyamı ekte size sunuyorum. Tesekkür ederim simdiden.

 

[Orion1]

Kodda bir düzeltme yapıldı.teslim aldı şartı sağlandı.

Dosyanız ekte.

Sub listele()
Dim i As Long, sat As Long, sut As Integer
Dim k As Integer, deg As Variant, j As Range, z As Long
Sheets(3).Select
If MsgBox("Liste Çıkarmak İstiyormusunuz!!??", vbYesNo + vbInformation, "LİSTE") = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set s2 = Sheets(2)
Set s3 = Sheets(3)
sat = 2
s3.Range("A2:B65536").ClearContents
z = s2.Cells(65536, "A").End(xlUp).Row
For i = 3 To z
    sut = s2.Cells(i, 256).End(xlToLeft).Column
    For k = 2 To sut
        If s2.Cells(i, k).Value = "teslim aldı" Then
            deg = s2.Cells(i, "A").Value & s2.Cells(2, k).Value
            Set j = Sheets(1).Range("A:A").Find(deg, , xlValues, xlWhole)
            If Not j Is Nothing Then
                s3.Cells(sat, "A").Value = deg
                s3.Cells(sat, "B").Value = j.Offset(0, 1).Value
                sat = sat + 1
            End If
        End If
    Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır..!!"
End Sub

 

[kayra75]

malesef calısmadı hata veriyor verdiği hatada makrolar devre dısı bırakılmıs olabilir yada makro yok.

 

[ersoyalan]

Merhaba,

Nasıl bir hata aldınız ben dosyayı denedim gayet güzel çalışıyor.

E.ALAN

 

[kayra75]

Merhaba simdi tamam calıstırabildim ama birsey sorucam range i nasıl değiştirebilirim belli bir bölüme kadar alıyor teslim aldı bilgisini p harfine kadar bide 25 e kadar aramasını istiyorum. cok tsk ederim.