başka xls sayfasından veri çekmek sicile göre

[dreamymost]

merhaba arkadaşlar. iki adet sayfam var. veri kısmında personelin detaylı bilgisi var . ayrı bir excel sayfası yaptık (sayfa.xls) orada bazı istenen bilgileri var . o bilgileri veride personelin sicil nosunu girdiğimizde veri den çekmesini istiyorum yardımcı olabilirmisiniz arkadaşlar ?

örnek : sayfa.xls dosyasında kişinin ad soyad adres telefon bilgisi isteniyor. sicil noyu girdiğimizde veriden bu bilgileri çekicek.

http://www.dosya.tc/server38/MTFoTL/sayfa.xlsx.html http://www.dosya.tc/server38/MTFoTL/veri.xlsx.html

 

[halit3]

Kodu bir modülün içine ekleyin ve bir komut düğmesine bağlayın.
veri alınacak sicil numaralarını a sütununa yazın ve komut düğmesini çalıştırın veri alınacak dosyayı seçin eğer dosyada birden fazla sayfa varsa kod size sayfa seçimi bilgisi getirecektir buradan veri alınacak sayfayı seçin tamam diyin.

kod:

Sub kapalıverial()

kap_dos_sütün_no = "A" 'veri alınacak kapalı dosyanın son dolu satırıma ait sutun adı
sonsat = 65000          'Rows.Count - 1
kap_dos_satir_no = 1    'veri alınacak kapalı dosyanın son dolu sütununa ait satır numarası


ekle1 = Cells(1, 3).Value
ekle2 = Cells(1, 4).Value
ekle3 = Cells(1, 5).Value

Kaynak = Application.GetOpenFilename("All Files (*.*),*.*.")
If Kaynak = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Klasor = fL.GetParentFolderName(Kaynak)
dosya = fL.GetFileName(Kaynak)

If Right(Klasor, 1) <> "\" Then Klasor = Klasor & "\"


deg = "'" & Klasor & "[" & dosya & "]" & X & "'!R"
Cells(1, 3).Value = "=" & deg & 1 & "C" & 1
Cells(1, 3).Replace What:="=", Replacement:=""
alan1 = Cells(1, 3).Value
alan2 = Right(alan1, InStr(1, StrReverse(alan1), "]", vbTextCompare))
alan3 = Right(alan2, InStr(1, StrReverse(alan2), "!", vbTextCompare))
SayfaAdi = Mid(alan2, 2, Len(alan2) - Len(alan3) - 2)
Cells(1, 3).Value = SayfaAdi

Range("B2:F65000").ClearContents

deg2 = Klasor & "[" & dosya & "]" & SayfaAdi
deg3 = "'" & Klasor & "[" & dosya & "]" & SayfaAdi & "'!R"

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 4).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
Cells(1, 4).Value = Cells(1, 4).Value
sut1 = Cells(1, 4).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 5).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"
Cells(1, 5).Value = Cells(1, 5).Value
sat1 = Cells(1, 5).Value ' Kapalı dosyaya ait son dolu satır sayısı

If Val(sut1) = 0 Or Val(sat1) = 0 Then MsgBox "son dolu satır ve son dolu sütunda değer yok": Exit Sub


For m = 2 To Cells(Rows.Count, "a").End(3).Row
aranan = Cells(m, 1).Value

For r = 1 To sat1 ' Kapalı dosyaya ait son dolu satır sayısı
If aranan = ExecuteExcel4Macro(deg3 & r & "C" & 1) Then

For j = 2 To 5 'sut1 ' Kapalı dosyaya ait son dolu sütun sayısı
Cells(m, j).Value = ExecuteExcel4Macro(deg3 & r & "C" & j) 'kapalı dosyadaki değerlere ait prosüdür
If Cells(m, j).Value = 0 Then
Cells(m, j).Value = ""
End If
Next j

Cells(m, 6).Value = ExecuteExcel4Macro(deg3 & r & "C" & 10)
If Cells(m, 6).Value = 0 Then
Cells(m, 6).Value = ""
End If

End If

Next r
Next m

Cells(1, 3).Value = ekle1
Cells(1, 4).Value = ekle2
Cells(1, 5).Value = ekle3

MsgBox "işlem tamam"

End Sub

 

[wiruuss]

Merhabalar
Düşeyara formülü de işinizi görebilir. Örnek bir dosya ekledim kontrol edersiniz.
http://www.dosya.tc/server38/jkHPKw/_RNEK.xlsx.html