aktarma makrosu hakkinda

[exclusiveman]

sevgili arkadaslar asagidaki makroyu sayin yurttas nickli arkadasimizdan ornek alarak ekliyorum. bu makroda d hucresine gore aktarma yapiyor; birinci sorum, d hucresi yerine baska bir hucreye gore uyarlama yapabilir miyiz? d olan yerleri ornegin e yaptigimda makro hata veriyor. ikinci sorum, bu makro tek kosula bagli yani d hucresindeki degere. iki hucreye gore aktarma yapabilirmiyiz? ornegin e="x" ve d="y" ise aktar gibi...
yardimlariniza cok ihtiyacim var lutfen esirgemeyin. bu arada formul ile de denedim ancak satir sayisi arttiginda excel asiri yavasliyor.

ornek dosya ektedir. icerisine aciklama yaptim. daha net anlasilmasi acisindan.

makro:

Option Explicit

Sub DAGIT()
Dim s1 As Worksheet
Dim sY As Worksheet
Dim ALAN As Range
Dim r As Integer
Dim c As Range
Set s1 = Sheets("VERİ")
Set ALAN = Range("VERİTABANI")


s1.Columns("d:d").Copy _
Destination:=Range("L1")
s1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row


Range("L1").Value = Range("d1").Value

For Each c In Range("J2:J" & r)

s1.Range("L2").Value = c.Value

If SAYFA(c.Value) Then
Sheets(c.Value).Cells.Clear
ALAN.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("VERİ").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set sY = Sheets.Add
sY.Move After:=Worksheets(Worksheets.Count)
sY.Name = c.Value
ALAN.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("VERİ").Range("L1:L2"), _
CopyToRange:=sY.Range("A1"), _
Unique:=False
End If
Next
s1.Select
s1.Columns("J:L").Delete
End Sub
Function SAYFA(SAYFAADI As String) As Boolean
On Error Resume Next
SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

aciklama: Set ALAN = Range("VERİTABANI") Bu alan Insert/Name/Define - Ekle/Ad/Tanımla dan ayarlaniyor.