Çözüldü Makro ile otomatik doldurma

[excellkurdu]

Arkadaşlar Merhaba,
Makro ile C sütununa Sayfa2 deki (açılır listeden) bir değeri girdiğimde, D tutununa Sayfa2 deki satırdaki değerini nasıl otomatik doldurabiliriz? Örnek Dosyam ektedir.
Elimde çalışan bir örnek var. Fakat 3 satırlıktı. Şimdi bunu 500 satır için yapmaya çalışınca kodları tek tek yazmam imkansız. Kolayı var mıdır?
Kullandığım Örnek Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C5")) Is Nothing Then GoTo 6
Call C5
Exit Sub
6
If Intersect(Target, Range("C6")) Is Nothing Then GoTo 7
Call C6
Exit Sub
7
If Intersect(Target, Range("C7")) Is Nothing Then GoTo 8
Call C7
Exit Sub
8
If Intersect(Target, Range("C8")) Is Nothing Then Exit Sub
Call C8
End Sub
Sub C5()
Application.ScreenUpdating = False
If Range("C5") <> "" Then
    Set BUL = Sheets("BiyosidallerFare").Range("A:A").Find(Range("C5").Value, , , xlWhole, , xlNext)
        If Not BUL Is Nothing Then
        [D5] = Sheets("BiyosidallerFare").Range("D" & BUL.Row)
   End If
End If
End Sub
Sub C6()
Application.ScreenUpdating = False
If Range("C6") <> "" Then
    Set BUL = Sheets("BiyosidallerFare").Range("A:A").Find(Range("C6").Value, , , xlWhole, , xlNext)
        If Not BUL Is Nothing Then
        [D6] = Sheets("BiyosidallerFare").Range("D" & BUL.Row)
   End If
End If
End Sub
Sub C7()
Application.ScreenUpdating = False
If Range("C7") <> "" Then
    Set BUL = Sheets("BiyosidallerFare").Range("A:A").Find(Range("C7").Value, , , xlWhole, , xlNext)
        If Not BUL Is Nothing Then
        [D7] = Sheets("BiyosidallerFare").Range("D" & BUL.Row)
   End If
End If
End Sub
Sub C8()
Application.ScreenUpdating = False
If Range("C8") <> "" Then
    Set BUL = Sheets("BiyosidallerFare").Range("A:A").Find(Range("C8").Value, , , xlWhole, , xlNext)
        If Not BUL Is Nothing Then
        [D8] = Sheets("BiyosidallerFare").Range("D" & BUL.Row)
   End If
End If
End Sub

 

[askm]

Aşağıdaki şekilde deneyin. Örnek dosyanızda ilgili sayfa olmadığı için kodu tam deneyemedim.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C5:C10000")) Is Nothing Then Exit Sub
If Target.Value <> "" Then
    Set BUL = Sheets("BiyosidallerFare").Range("A:A").Find(Target.Value, , , xlWhole, , xlNext)
        If Not BUL Is Nothing Then
        Cells(Target.Row, 4) = Sheets("BiyosidallerFare").Range("D" & BUL.Row)
   End If
End If
End Sub

 

[Haluk]

Tam anlamadım ama; ekli dosyaya bir bakın ....

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C5:C309")) Is Nothing Then
        Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, Sheets("Sayfa2").Range("A1:D135"), 4, False)
    End If
End Sub

.

 

[excellkurdu]

askm ve Haluk hocalarım çok teşekkür ederim. Gayet güzel olmuş emeğinize ellerinize sağlık.