Başka Kapalı Dosyadan Veri Alma

[shadow2766]

Aynı konuyu daha önce yazdım fakat konuyu gönder dediğimde sunucuya fazla yüklenme var dedi ve açtığım konunun linkinde sorun oldu o yüzden tekrar yazdım kusura bakmayın.Tekrar aynı konuyu yazıyorum.
Daha önce araştırdım,birkaç şey buldum ama beceremedim sizden yardım almak istiyorum şimdiden ilgilenen herkese teşekkür ederim. Arkadaşlar ekte mevcut olan Çalışma 1 ve Çalışma 2 dosyalarıyla ilgili bir sıkıntım var. Çalışma 2 dosyasında bulunan E sütunundaki fiyatları Çalışma 1 dosyasına A sütunlarına göre karşılık gelecek şekilde fiyatları otomatik olarak atmak istiyorum. Bazı ürünlerin kodları aynı satırlarda yer almadığından zorlandım formül kurmakta. Örneğin Çalışma 1 dosyasının A sütunundaki 00141 kodlu ürün 43. satırda fakat Çalışma 2 dosyasında 34. sırada.Bunları nasıl eşleştirebilirim? Bunun gibi uğraşmam gereken yaklaşık 1200 satırlık ürün var yardımcı olursanız çok sevinirim.

http://s3.dosya.tc/server21/jCP5Cv/_al__ma2.xlsx.html
http://s3.dosya.tc/server21/jCP5Cv/_al__ma1.xlsx.html

 

[Orion1]

Dosyanız ektedir.
Calisma1 adlı excel dosyasındaki butona tıklayınız.

Sub fiyat59()
Dim k As Range, sat As Long, conn As Object, rs As Object
Sheets("Sayfa1").Select
Range("E2:E" & Rows.Count).ClearContents
sat = Cells(Rows.Count, "A").End(xlUp).Row
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Calisma2.xlsx;extended properties=""excel 12.0;hdr=yes;imex=1""")
rs.Open "select KOD,FİYAT from[SAYFA1$];", conn, 1, 1
If rs.RecordCount = 0 Then GoTo son
rs.movefirst
Do While Not rs.EOF
    If Not IsNull(rs("KOD").Value) Then
        Set k = Range("A2:A" & sat).Find(CStr(rs("KOD").Value), , xlValues, xlWhole)
        If Not k Is Nothing Then Cells(k.Row, "E").Value = rs("FİYAT").Value
        Set k = Nothing
    End If
    rs.movenext
Loop
son:
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
MsgBox "İŞlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
    
End Sub

 

[shadow2766]

Dosyayı indiremiyorum maalesef. Yetkiniz yoktur uyarısı alıyorum. Başka türlü gönderme şansınız var mı acaba?

 

[shadow2766]

Altın üyelik alarak hallettim. Çok teşekkür ederim Orion,sayende büyük bir dertten kurtuldum.Yalnız birşey daha sormak istiyorum.Benim kullanacağım dosya şimdi farklı yani koddaki Set rs = CreateObject("Adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Calisma2.xlsx;extended properties=""excel 12.0;hdr=yes;imex=1""") kısmına kullanacağım dosyayı nasıl yazacağım?

 

[Orion1]

Altın üyelik alarak hallettim. Çok teşekkür ederim Orion,sayende büyük bir dertten kurtuldum.Yalnız birşey daha sormak istiyorum.Benim kullanacağım dosya şimdi farklı yani koddaki Set rs = CreateObject("Adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Calisma2.xlsx;extended properties=""excel 12.0;hdr=yes;imex=1""") kısmına kullanacağım dosyayı nasıl yazacağım?

Yukarıdaki kırmızı satırda dosya yolu ve adı yazlıdır.siz bunun yerine kendi dosyanızın yolunu ve dosyanızın adını yazınız.

 

[shadow2766]

çok teşekkür ederim