Veri almada hata

[mars2]

İyi Akşamlar;

excel çalışma kitabımın Liste (Sayfa1) sayfasında Liste, Kayıt (Sayfa2) sayfasında ise tablo bulunmaktadır. Kayıt (Sayfa2) sayfasındaki tabloya dosya nolarına göre veriler aktarmak istiyorım. Ancak, B18 ila B25 arasındaki hücrelere Liste sayfasındaki isimleri alt alta gelecek şekilde olması gerekmektedir.

Kayıt sayfasında bulunan tablonun 1. bölümüne aşağıdaki makro ile veriler gelmektedir.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

If Intersect(Target, [C4]) Is Nothing Then Exit Sub
If Target.Value = Empty Then Exit Sub

Set S1 = Sheets("kayıt")
Set S2 = Sheets("Liste")

Range("C7:C12").ClearContents
Range("G9:G10").ClearContents
Range("B18:B25").ClearContents

For Each bul In S2.Range("B5:B5000")
If bul = Target.Value Then sat = bul.Row
Next
If sat = "" Then
MsgBox "ARADIĞINIZ BULUNAMADI.", vbInformation, "BİLGİ"

Exit Sub
End If

S1.Cells(7, "C").Value = S2.Cells(sat, "D").Value
S1.Cells(8, "C").Value = S2.Cells(sat, "E").Value
S1.Cells(9, "C").Value = S2.Cells(sat, "G").Value
S1.Cells(10, "C").Value = S2.Cells(sat, "I").Value
S1.Cells(12, "C").Value = S2.Cells(sat, "F").Value

S1.Cells(9, "G").Value = S2.Cells(sat, "H").Value
Set S1 = Nothing
Set S2 = Nothing

If Not Intersect(Range("C4"), Target) Is Nothing Then
.......

Ancak, B18 ila B25 hücrelerine verilerin gelebilmesi için aşağıdaki makroyu eklediğimde (Daha önceden yayımlanan makroyu uyarladığımda) hiç veri gelmemeketedir.

If Not Intersect(Range("C4"), Target) Is Nothing Then
Application.EnableEvents = False
Target.Offset(4).Resize(3).Value = ""
Cells(18, Target.Column) = ""
With Worksheets("Liste")
Set bul = .Range("B2:B5000").Find(what:=Target.Text, lookat:=xlWhole)
If Not bul Is Nothing Then
Isimler = Split(.Cells(bul.Row, "Q").Text, ",")
If UBound(Isimler) < 0 Then
Cells(18, Target.Column) = .Cells(bul.Row, "Q").Text
Else
For Bak = 0 To UBound(Isimler)
Cells(18 + Bak, Target.Column) = Isimler(Bak)
Next
End If
End If
End With
End If
End Sub

Acaba nerede hata yapılmaktadır.

 

[Korhan Ayhan]

Merhaba,

Dosya numarasına ait ADI SOYADI sayısı 10 satırı geçebiliyor mu? Geçme durumu varsa KAYIT sayfasında ADI SOYADI alanına satır eklenmesi gerekir.

 

[mars2]

Sayın Korhan bey;

Dosya numarasına ait ADI SOYADI sayısı 10'dan fazla olmamakla birlikte nadir olsa da olabilir. Ekleme yapabilirim.

 

[Korhan Ayhan]

Deneyiniz.

Adı Soyadı bloğunu b18:d27 olarak dosyanızdaki gibi baz aldım.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range, X As Variant
   
    If Intersect(Target, [C4]) Is Nothing Then Exit Sub
    If Target(1) = "" Then GoTo Son
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
   
    With Sheets("kayıt")
        .Range("C7:K8,C9:D10,G9:K10,B18:D27").ClearContents
       
        Set Bul = Sheets("Liste").Range("B6:B" & Rows.Count).Find(Target, , , xlWhole)
       
        If Bul Is Nothing Then
            Target.Select
            MsgBox "Aradığınız kayıt bulunamadı!", vbCritical
            GoTo Son
        End If
       
        .[C7] = Bul.Offset(, 2)     ' D sütunu
        .[C8] = Bul.Offset(, 3)     ' E sütunu
        .[C9] = Bul.Offset(, 5)     ' G sütunu
        .[G9] = Bul.Offset(, 6)     ' H sütunu
        .[C10] = Bul.Offset(, 7)    ' I sütunu
        .[C12] = Bul.Offset(, 4)    ' F sütunu
       
        X = Split(Bul.Offset(, 15), ",")  ' Q sütunu
        .[B18].Resize(UBound(X) + 1) = Application.Transpose(X)
    End With
   
Son:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

 

[mars2]

Sayın Korhan bey;
Yukarıda kodu uyguladığımda, herhangi hata vermeden çalıştı.

Emeğinize ve ilginize teşekkürler.