Veri Aktarımı

[domino]

Ekte gönderdiğim dosyada iki adet ecxel dosyası bulunmaktadır. Birincisi internete yüklediğim veriler dosyası ikincisi bilgisayarımda bulunan ana dosya
Ana dosyada adı soyadı kısmına yazmış olduğum isime göre veriler dosyasındaki o isme karşılık gelen bilgilerin aşağıda yer almasını istiyorum. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[asi_kral]

Ekte gönderdiğim dosyada iki adet ecxel dosyası bulunmaktadır. Birincisi internete yüklediğim veriler dosyası ikincisi bilgisayarımda bulunan ana dosya
Ana dosyada adı soyadı kısmına yazmış olduğum isime göre veriler dosyasındaki o isme karşılık gelen bilgilerin aşağıda yer almasını istiyorum. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

Merhaba
Boş bir module Kopyalayın ve deneyin.

Option Explicit
Sub karşılık_bul_1967()
'Konu       :   Karşılık Bulma
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long, yol As String, kapalı As String
Application.ScreenUpdating = False
Set s1 = Workbooks(ActiveWorkbook.Name).Sheets("Ana")
yol = ThisWorkbook.Path & "\"
kapalı = "Veriler.xlsx"
Workbooks.Open (yol & kapalı)
Set s2 = Workbooks(kapalı).Sheets("VERİLER")
s1.Range("C4:C11").ClearContents
If s1.Range("C3") <> Empty Then
If WorksheetFunction.CountIf(s2.Range("A:A"), s1.Range("C3")) > 0 Then
a = WorksheetFunction.Match(s1.Range("C3"), s2.Range("A:A"), 0)
s1.Range("C4") = s2.Cells(a, "B")
s1.Range("C5") = s2.Cells(a, "C")
s1.Range("C6") = s2.Cells(a, "D")
s1.Range("C7") = s2.Cells(a, "E")
s1.Range("C8") = s2.Cells(a, "F")
s1.Range("C9") = s2.Cells(a, "G")
s1.Range("C10") = s2.Cells(a, "H").Value
s1.Range("C11") = s2.Cells(a, "I").Value
End If: End If
Workbooks(kapalı).Close
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte