Düşey Arama Çok Yavaş

[cember68]

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [C1:C3002]) Is Nothing Then Exit Sub
Call ara
End Sub


Sub ara()

Dim ws As Worksheet
Dim DataRange As Range
Dim UpdateRange As Range
Dim aCell As Range
Dim bCell As Range
On Error GoTo Err
Set ws = Worksheets("1")
Set ds = Worksheets("TALEP")


Set UpdateRange = ws.Range("C2:C3002")
Set DataRange = ds.Range("A1:A3002")
For Each aCell In UpdateRange
Set bCell = DataRange.Find(What:=aCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.Offset(, 1) = bCell.Offset(, 1)
aCell.Offset(, 2) = bCell.Offset(, 2)
aCell.Offset(, 3) = bCell.Offset(, 3)
aCell.Offset(, 4) = bCell.Offset(, 4)
aCell.Offset(, 5) = bCell.Offset(, 6)
aCell.Offset(, 6) = bCell.Offset(, 7)
aCell.Offset(, 7) = bCell.Offset(, 8)
aCell.Offset(, 8) = bCell.Offset(, 9)
aCell.Offset(, 9) = bCell.Offset(, 10)




End If
Next
Exit Sub


End Sub




Yukarıdaki kod ile TALEP sayfasından veri arayıp 1 sayfasına veri çekiyorum.Veri aralığı 3000 satır. Fakat arama çok yavaş.Sütundaki verileri her seferinde baştan aradığı için mi?Yardımcı olabilecek var mı?

 

[karahacioglu]

Bunu excel dosyası olarak gönderirseniz bilenler yardımcı olabilir. Bu gönderecek olduğunuz dosyayı bir sitede yükleyip (dosyaupload.com gibi) sonra linki gönderirseniz yardımcı olurlar diye düşünüyorum.

 

[alprn19]

Range("'Sayfa1'!D5")=WorksheetFunction.VLookup(Sheets("Sayfa1").Range("D4"), Sheets("Sayfa2").Range("C3:Bl200"), 2, False)

Makroda düşey arada bu formülü kullanıyorum. Yavaşlığını görmedim.

 

[cember68]

Private Sub Worksheet_Change(ByVal Target As Range)

Dim S1 As Worksheet, c As Range
Dim S2 As Worksheet

Set S1 = Sheets("TALEP")
Set S2 = Sheets("1")

If Intersect(Target, [C:C]) Is Nothing Then Exit Sub

With Target
Set c = S1.[A:A].Find(.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
.Offset(0, 1) = S1.Range("B" & c.Row)
.Offset(0, 2) = S1.Range("C" & c.Row)
.Offset(0, 3) = S1.Range("D" & c.Row)
.Offset(0, 4) = S1.Range("E" & c.Row)
.Offset(0, 5) = S1.Range("G" & c.Row)
.Offset(0, 6) = S1.Range("H" & c.Row)
.Offset(0, 7) = S1.Range("I" & c.Row)
.Offset(0, 8) = S1.Range("J" & c.Row)




Else
Range("D" & .Row & ":F" & .Row).ClearContents
MsgBox "Veriyi Bulamadım"
End If
End With

End Sub




Yukarıdaki gibi düzenledin hızlandı.Cevaplarınız için teşekkür ederim.