VBA ile farklı klasörden düşeyara

[kandemir76]

Merhaba ,
Örneğin C:\kisiler\maaslar.xls dosyasın A1 sütununa Ali yazdığımda Alinin maaş bilgilerini d:\personel\personel.xls dosyasının B1 hücresinden çekmek istiyorum. VBA ile düşeyara yapmak mümkün müdür?
Saygılar.

Hocam Mesajı yeniden düzenledim.Dosyaları ekledim.

Not: d:\personel\personel.xls dosyasının A sütünunda isimler B sütünunda maaşlar var.
Not:Her iki dosya aynı klasörde iken çalışan örneğini buldum.

 

[İhsan Tank]

Merhaba ,
Örneğin C:\kisiler\maaslar.xls dosyasın A1 sütununa Ali yazdığımda Alinin maaş bilgilerini d:\personel\personel.xls dosyasının B1 hücresinden çekmek istiyorum. VBA ile düşeyara yapmak mümkün müdür?
Saygılar.

Not: d:\personel\personel.xls dosyasının A sütünunda isimler B sütünunda maaşlar var.
Not:Her iki dosya aynı klasörde iken çalışan örneğini buldum.

Dosyalarınızı ekleme imkanınız var mı_?
Birde bilgileri çekerken otomatik arka planda açılsa ve kapansa problem olur mu_?

 

[kandemir76]

Dosyalarınızı ekleme imkanınız var mı_?
Birde bilgileri çekerken otomatik arka planda açılsa ve kapansa problem olur mu_?

Merhaba Hocam, dosyaları ekledim. Arka planda açılıp kapanması hiç problem değil.

 

[İhsan Tank]

Merhaba Hocam, dosyaları ekledim. Arka planda açılıp kapanması hiç problem değil.

Merhaba
Maaşlar Dosyasında boş bir module oluşturun ve kodu oraya kopyalayıp deneyin.

Option Explicit
Sub bilgi_çek_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
Dim bordo, mavi, asi
trabzonspor = MsgBox("Maaşları Alıyorum Emin Misiniz", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
trabzonspor = ActiveWorkbook.Name
kaplan = ActiveSheet.Name
bordo = "D:\personel\"
mavi = "personel.xls"
asi = "Sayfa1"
Workbooks.Open (bordo & mavi)
For ts = 2 To Workbooks(trabzonspor).Sheets(kaplan). _
Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Workbooks(mavi). _
Sheets(asi).Range("A:A"), Workbooks(trabzonspor).Sheets _
(kaplan).Cells(ts, "A")) > 0 Then
Workbooks(trabzonspor).Sheets(kaplan).Cells(ts, "B") = _
WorksheetFunction.VLookup(Workbooks(trabzonspor).Sheets(kaplan). _
Cells(ts, "A"), Workbooks(mavi).Sheets(asi).Range("A:B"), 2, 0)
End If
Next
Workbooks(mavi).Close
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Maaşları Aldım", , "Bitiş"
End Sub

 

[İhsan Tank]

Üstteki kodda bir sıkıntı vardı onu düzenleyip güncelledim.

 

[kandemir76]

Teşekkür ederim. Emeğinize sağlık

Hocam emeğinize sağlık.

 

[İhsan Tank]

Hocam emeğinize sağlık.

Kolay Gelsin
:keyif: