başka sayfadaki verileri çekmek

[Schuba]

açıklama ektedir bakıp yardımcı olan arkadaşa şimdiden teşekkürler

 

[Muzaffer Ali]

Form sayfasının kod bölümüne aşağıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("C4")) Is Nothing Then Exit Sub
    Range("C8").Value = WorksheetFunction.VLookup(Range("C4"), Worksheets("LİSTE").Range("C:H"), 3, 0)
    Range("C10").Value = WorksheetFunction.VLookup(Range("C4"), Worksheets("LİSTE").Range("C:H"), 4, 0)
    Range("C12").Value = WorksheetFunction.VLookup(Range("C4"), Worksheets("LİSTE").Range("C:H"), 5, 0)
    Range("F8").Value = WorksheetFunction.VLookup(Range("C4"), Worksheets("LİSTE").Range("C:H"), 6, 0)
    Range("F4").Value = WorksheetFunction.VLookup(Range("C4"), Worksheets("LİSTE").Range("C:H"), 2, 0)
End Sub

 

[Orion1]

Dosyanız ektedir.

Sub personel59()
Dim cnn As Object, rs As Object
Set cnn = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
Sheets("FORM").Select
If Not IsNumeric(Range("C4").Value) Then
    MsgBox "Personel kodu sayısal bir değer olmalıdır.İşlem iptal oldu"
    Range("C4").Select
    GoTo son
End If
Range("F4").Value = Empty
Range("C8").Value = Empty
Range("C10").Value = Empty
Range("C12").Value = Empty
Range("F8").Value = Empty
cnn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & _
            ";extended properties=""excel 12.0;HDR=No"";"
rs.Open "select top 1 * from[LİSTE$C4:H65536] where F1=" & Range("C4").Value & ";", cnn, 1, 1
If rs.RecordCount > 0 Then
    rs.movefirst
    Range("F4").Value = rs("F2").Value
    Range("C8").Value = rs("F3").Value
    Range("C10").Value = rs("F4").Value
    Range("C12").Value = rs("F5").Value
    Range("F8").Value = rs("F6").Value
End If
son:
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
MsgBox "İşlem tamam" & vbLf & "evrengizlen@hotmail.com"

End Sub

 

[Haluk]

2. mesajdaki yönteme alternatif yazım şekli;

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C4")) Is Nothing Then
        Range("F4") = [vlookup(C4,Liste!C4:H91,2,False)]
        Range("C8") = [vlookup(C4,Liste!C4:H91,3,False)]
        Range("C10") = [vlookup(C4,Liste!C4:H91,4,False)]
        Range("C12") = [vlookup(C4,Liste!C4:H91,5,False)]
        Range("F8") = [vlookup(C4,Liste!C4:H91,6,False)]
    End If
End Sub

.

 

[Schuba]

değerli hocalarım öncelikle geri dönüşleriniz için hepinize teşekkür ederim

göndermiş olduğunuz kodlarda veri çekme olayı gayet güzel fakat kodları dosyada incelerken sıralamak gerekirse
2' inci mesajda gelen kodda verileri gayet güzel çekiyor fakat (C4) hücresine yani personel kodunun olduğu alanı temizlerken kod hata veriyor
3' cü mesajda gelen kodda verileri gayet güzel çekiyor fakat oda aynı şekilde (C4) hücresinin içini temizlerken kod hata veriyor
4'üncü mesajda gelen kodda verileri gayet güzel çekiyor fakat bu kod (C4) hücresinin içini temizlerken hata vermiyor burası güzel ama (C4) hücresinin içini temizlerken diğer hücrelerin içinde #YOK yazıyor

ben bu kodların içinden 4 üncü mesajdaki kodu daha kısa ve (C4) hücresini temizlerken kod hatası vermediği için bu kodu daha uygun buldum
diğer hücrelerde #YOK yazıyor olayınıda 4 üncü mesajdaki koda biraz ilave yaparak çözdüm.
eklediğim kod ile beraber (C4) hücresini temizlerken artık #YOK yazmıyor form sayfasındaki hücreler boş görünüyor sorun çözüldü anlayacağınız.

fakat çözemediğim tek bir olay kaldı oda şöyleki (C4) hücresinin içini temizledikten sonra #YOK yazıyor olayını hallettim ama
halledemediğm olay (C4) hücresine girdiğim personel kodu eğer liste sayfasında yoksa yine halen #YOK yazıyor

istediğim ve yapamadığım olay (C4) hücresine girdiğim personel kodu eğer liste sayfasında yoksa form sayfasındaki hücreler boş görünsün
#YOK yazmasın..

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C4")) Is Nothing Then
    If Range("C4").Value = "" Then
    Range("F4,C8,C10,C12,F8").Select
    Selection.ClearContents
    Range("F8").Select
    Else
        Range("F4") = [vlookup(C4,Liste!C4:H91,2,False)]
        Range("C8") = [vlookup(C4,Liste!C4:H91,3,False)]
        Range("C10") = [vlookup(C4,Liste!C4:H91,4,False)]
        Range("C12") = [vlookup(C4,Liste!C4:H91,5,False)]
        Range("F8") = [vlookup(C4,Liste!C4:H91,6,False)]
    End If
    End If
End Sub

 

[turist]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [C4]) Is Nothing Then Exit Sub
        [F4] = [iferror(vlookup(C4,Liste!C:H,2,False),"""")]
        [C8] = [iferror(vlookup(C4,Liste!C:H,3,False),"""")]
        [C10] = [iferror(vlookup(C4,Liste!C:H,4,False),"""")]
        [C12] = [iferror(vlookup(C4,Liste!C:H,5,False),"""")]
        [F8] = [iferror(vlookup(C4,Liste!C:H,6,False),"""")]
End Sub

şeklinde deneyin.
Not:#4.Nolu mesajın isteğinize cevap verecek düzenlemesidir.

 

[Schuba]

turist hocam teşekkürler sizin gönderdiğiniz kod gayet başarılı sadece fazladan galiba ("") iki tırnak eklemişsiniz oda diğer boş hücrelerde (") şeklinde görünüyordu
onlarıda aşağıdaki gibi düzenledim tam istediğim gibi çalışıyor teşekkür ederim..

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [C4]) Is Nothing Then Exit Sub
        [F4] = [iferror(vlookup(C4,Liste!C:H,2,False),"")]
        [C8] = [iferror(vlookup(C4,Liste!C:H,3,False),"")]
        [C10] = [iferror(vlookup(C4,Liste!C:H,4,False),"")]
        [C12] = [iferror(vlookup(C4,Liste!C:H,5,False),"")]
        [F8] = [iferror(vlookup(C4,Liste!C:H,6,False),"")]
End Sub

 

[Orion1]

C4 hücresini temizlemiyeceksiniz.
Onda personel numarası yazılı olacak ve o personel numarasına göre arama yapılacak.
Benim kodda C4 tetiklenmesi ile çalışmamaktadır.
Butona basınca çalışmaktadır.
Silerseniz hata verir.