Farklı Kitaptan Vlookup çekme

[Taha ell]

Merhaba;
Çalışma kitabı içerisindeki A sütununu Data kitabında aratarak Data kitabının B sütununa karşılık gelen değeri Çalışma kitabında B sütununa yazdırmak istiyorum. Amacım farklı server daki kşilerin kendine ait olan çalışma kitabında bulunan numaraların ortak alanda sürekli güncellenen data kitabında olup olmadığını görmeleri fakat data kitabı kapalı olduğu zaman vlookup ile otomatik çekemiyorum. Bunun yerine çalışma kitabına buton koyarak o butona basıldığında güncelleme sağlanmasını istiyorum. kod yolunu görmek için her iki kitabıda ekledim. Umarım açıklayıcı olmuştur. Desteklerinizi beklerim. Kolaylıklar.

 

[Emir Hüseyin Çoban]

. . .

Dosyanız ektedir.
Aşağıda belirttiğim kırmızı alan dosya yoludur. Kendi ayarlarınıza göre değiştirin.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

Dim KD As Workbook
Dim KC As Workbook

yol = [B][COLOR="Red"]"\\192.168.2.250\userdata2\HÜSEYİN ÇOBAN"[/COLOR][/B]

Set KD = Workbooks.Open(yol & "\Data.xlsx")
Set KC = Workbooks("çalışma")

KC.Sheets("Sayfa1").Range("B2:B65536").ClearContents

For i = 2 To KC.Sheets("Sayfa1").[A65536].End(3).Row
If KC.Sheets("Sayfa1").Cells(i, "A") <> "" Then

    If WorksheetFunction.CountIf(KD.Sheets("Sayfa1").Range("A:A"), KC.Sheets("Sayfa1").Cells(i, "A")) > 0 Then 'EĞERSAY
        KC.Sheets("Sayfa1").Cells(i, "B") = WorksheetFunction.VLookup(KC.Sheets("Sayfa1").Cells(i, "A"), KD.Sheets("Sayfa1").Range("A:B"), 2, 0) 'DÜŞEYARA
    Else
        KC.Sheets("Sayfa1").Cells(i, "B") = "Yok"
    End If
    
Else
'MsgBox " Aranan Değer Boş ", vbCritical
End If

Next i

KD.Close False

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox " B i t t i "
End Sub

. . .

 

[Taha ell]

Patron bugün deneyebildim. Kusursuz çalışıyor. Emeğine sağlık.
Bir ekleme isteyeceğim sizden bu butona bastığımızda a yı aratıp b ye yazarken aynı anda c yi de aratıp d ye yazdırabilir miyiz. Tek butonla. Ben biraz uğraştım ama yapamadım. Yardımcı olursanız sevinirim. Kolaylıklar.

 

[Emir Hüseyin Çoban]

. . .

C sütunundaki veriyi
Data sayfasında, A sütununda mı aratacak ?

. . .

 

[Taha ell]

a sutununundaki gibi c sutununda da aynı işlemi yapıcak data da a sütununda aratıp datadaki b yi çalışma da d ye yazacak

 

[Emir Hüseyin Çoban]

. . .

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

Dim KD As Workbook
Dim KC As Workbook

yol = "C:\Users\Huseyin\Desktop\Çalışma_01"

Set KD = Workbooks.Open(yol & "\Data.xlsx")
Set KC = Workbooks("çalışma")

KC.Sheets("Sayfa1").Range("B2:B65536,D2:D65536").ClearContents

ason = KC.Sheets("Sayfa1").[A65536].End(3).Row
cson = KC.Sheets("Sayfa1").[C65536].End(3).Row

If ason > cson Then
son = ason
Else
son = cson
End If

For i = 2 To son

For a = 1 To 3 Step 2

If KC.Sheets("Sayfa1").Cells(i, a) <> "" Then

    If WorksheetFunction.CountIf(KD.Sheets("Sayfa1").Range("A:A"), KC.Sheets("Sayfa1").Cells(i, a)) > 0 Then 'EĞERSAY
        KC.Sheets("Sayfa1").Cells(i, a + 1) = WorksheetFunction.VLookup(KC.Sheets("Sayfa1").Cells(i, a), KD.Sheets("Sayfa1").Range("A:B"), 2, 0) 'DÜŞEYARA
    Else
        KC.Sheets("Sayfa1").Cells(i, a + 1) = "Yok"
    End If
    
Else
'MsgBox " Aranan Değer Boş ", vbCritical
End If

Next a

Next i

KD.Close False

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox " B i t t i "
End Sub

. . .