Hediye dağılımı

[ocak26]

Merhaba Arkadaşlar
Liste Ektedir Listede açıklama yaptığım gibi yardımcı olursanız sevinirim..
şimdiden çok çok teşekkür ederim..

 

[YUSUF44]

Ekteki dosyayı inceleyiniz:

https://drive.google.com/file/d/0B43WMUs21VpfNGpLSVg0dTIzSFk/view?usp=sharing

 

[Orion1]

Dosyanız ektedir.

Sub hediye59()
Dim sh As Worksheet, sonsat As Long
Range("A2:B" & Rows.Count).Clear
Set sh = Sheets("Sayfa 1")
sh.Range("A1").AutoFilter
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A1").AutoFilter field:=1, Criteria1:=Range("E1").Value
sh.Range("A1").CurrentRegion.Offset(1, 0).Copy Range("A2")
Application.ScreenUpdating = True
sh.Range("A1").AutoFilter
End Sub
Sub isim59()
Dim sh As Worksheet, sonsat As Long
Range("A2:B" & Rows.Count).Clear
Set sh = Sheets("Sayfa 1")
sh.Range("A1").AutoFilter
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A1").AutoFilter field:=2, Criteria1:=Range("E1").Value
sh.Range("A1").CurrentRegion.Offset(1, 0).Copy Range("A2")
Application.ScreenUpdating = True
sh.Range("A1").AutoFilter
End Sub