Başka Dosyadan Veri Çekmek

[baydeniro]

Merhaba arkadaşlar,

Ekranda açık olan DATA dosyası MERKEZ sayfasının A sütununda bulunan verilerden KAYIT dosyasının RAPOR sayfasının H2 hücresindeki tanım ile eşleşen verileri RAPOR sayfasına taşıyabilir miyiz ?

Örnek dosyaların linki :
http://s5.dosya.tc/server5/5zdszt/KAYIT.xls.html
http://s5.dosya.tc/server5/5zdszt/DATA.xls.html

 

[PLİNT]

Merhaba
Ek dosyayı denermisiniz?
"DATA" dosyasını açacak, filtreleyecek; "Kayıt" dosyasına kopyalayacaktır.
http://s5.dosya.tc/server5/zkn716/KAYIT.zip.html

 

[baydeniro]

Çok teşekkür ediyorum sayın PLİNT. elleriniz dert görmesin, emeğinize sağlık. Sağlıcakla kalın.

 

[mars2]

İyi Günler;
Sayın PLİNT, çalışmanız güzel olmuş ancak, DATA dosyası aynı klasörde değilde bilgisayarın "D", "E" veya farklı bir bölümünde olması halinde verileri nasıl çekecek.

 

[PLİNT]

Çok teşekkür ediyorum sayın PLİNT. elleriniz dert görmesin, emeğinize sağlık. Sağlıcakla kalın.

Rica ederim, kolay gelsin.

İyi Günler;
Sayın PLİNT, çalışmanız güzel olmuş ancak, DATA dosyası aynı klasörde değilde bilgisayarın "D", "E" veya farklı bir bölümünde olması halinde verileri nasıl çekecek.

Merhaba
Kodlardaki aşağıdaki satırı

[SIZE="2"]Workbooks.Open ThisWorkbook.Path & "\" & "DATA.xls"[/SIZE]

şöyle değiştirerek olabilir;

[SIZE="2"]Workbooks.Open "D:\" & "DATA.xls"[/SIZE]

veya
Pencereden seçerek;

[SIZE="2"]Sub getir()
Dim s1 As Worksheet, s2 As Worksheet
Dim x As Long
Dim ds, sd
Set s1 = ThisWorkbook.Sheets("RAPOR")
If Trim(s1.[H2]) = Empty Then Exit Sub
s1.Range("A2:B" & Rows.Count).ClearContents
Application.ScreenUpdating = False
Set sd = CreateObject("Shell.Application")
Set ds = sd.BrowseForFolder(0, "Dosya seçiniz:", &H4000)
If ds Is Nothing Then MsgBox "DOSYA SEÇİLMEDİ": Exit Sub
If ds.items.Item.Path Like "*.xls*" Then
Workbooks.Open ds.items.Item.Path
Else
MsgBox "DOSYA SEÇİLMEDİ": Exit Sub
End If
If ds.items.Item <> "DATA" Then MsgBox "DATA DOSYASI SEÇİLMEDİ": Exit Sub
On Error Resume Next
Set s2 = Workbooks("DATA").Sheets("MERKEZ")
If Err > 0 Then MsgBox "MERKEZ SAYFASI BULUNAMADI": GoTo 10
x = s2.Cells(Rows.Count, "A").End(3).Row
    s2.Range("A1").AutoFilter
s2.Range("$A$1:$B$" & x).AutoFilter Field:=1, Criteria1:=Trim(s1.[H2])
s2.Range("$A$2:$B$" & x).SpecialCells(xlCellTypeVisible).Copy
s1.Range("A2").PasteSpecial Paste:=xlPasteValues
10:
Workbooks("DATA").Close savechanges:=False
Application.ScreenUpdating = True
End Sub[/SIZE]