• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı çalışma kitaplarındaki verilerden liste oluşturma

Sizin verdiğiniz kodlarla farklı firmalardan gelen fiyatları çekebiliyoruz teklif karşılaştırma listesine. Ama teklif karşılaştırma listesindeki kalemleride ana dosyadan çekmemiz gerekiyor.

Senaryoyu anlatayım isterseniz.
2016_072 vb isimlerde teklifler hazırlayıp tedarikçi firmalara gönderiyorum. 2016_072 ana listemiz ve boş.
Firmalardan gelen teklifleri 2016_072A 2016_072B olarak farklı firmalar için fiyatları dolu bir şekilde yeniden kaydediyorum. 2016_072TK adında teklif gönderen firmaların fiyatlarını bir arada göreceğim bir teklif karşılaştırma listesi oluşturuyorum. Teklif karşılaştırma listesine ilk gönderdiğiniz kodla fiyatları çekebiliyorum ancak ürün kalemlerinin dolu olması gerekiyor.
Bu ürün kalemlerinide bu listelerden birinden çekmeye çalıştım bu kodları deneyerek.
Kod bilgim olmadığı için var olan kodlar üzerinde mantık yürüterek düzenleme yapabiliyorum sadece malesef.
 
ardakose' Alıntı:
Sizin verdiğiniz kodlarla farklı firmalardan gelen fiyatları çekebiliyoruz teklif karşılaştırma listesine. Ama teklif karşılaştırma listesindeki kalemleride ana dosyadan çekmemiz gerekiyor.

Senaryoyu anlatayım isterseniz.
2016_072 vb isimlerde teklifler hazırlayıp tedarikçi firmalara gönderiyorum. 2016_072 ana listemiz ve boş.
Firmalardan gelen teklifleri 2016_072A 2016_072B olarak farklı firmalar için fiyatları dolu bir şekilde yeniden kaydediyorum. 2016_072TK adında teklif gönderen firmaların fiyatlarını bir arada göreceğim bir teklif karşılaştırma listesi oluşturuyorum. Teklif karşılaştırma listesine ilk gönderdiğiniz kodla fiyatları çekebiliyorum ancak ürün kalemlerinin dolu olması gerekiyor.
Bu ürün kalemlerinide bu listelerden birinden çekmeye çalıştım bu kodları deneyerek.
Kod bilgim olmadığı için var olan kodlar üzerinde mantık yürüterek düzenleme yapabiliyorum sadece malesef.
Genişletmek için tıkla ...

Gönderdiğim kodlar çalışıyor mu ?
Çalışıyorsa bu kodlara ilave olarak ne istiyorsunuz ?
 
Gönderdiğiniz kodlar çalışıyor. İlave olarak malzeme en boy kalite ve miktarlarıda listeden çekmek istiyorum.
 
Teşekkür ederim. Tam olarak anlatamadım yapmak istediğimi kusura bakmayın kendim biraz uğraşıp beceremezsem daha detaylı güzel bir anlatımla tekrar yardım talep edeceğim. Tekrar teşekürler.
 
ardakose' Alıntı:
Teşekkür ederim. Tam olarak anlatamadım yapmak istediğimi kusura bakmayın kendim biraz uğraşıp beceremezsem daha detaylı güzel bir anlatımla tekrar yardım talep edeceğim. Tekrar teşekürler.
Genişletmek için tıkla ...

Deneyin.
Olmazsa dosyanızda nasıl olması gerektiğini el ile yazın ona göre yardımcı olmaya çalışırım.
 
Mehmet Bey teşekkür ederim ilginize. İstediğim yapıyı oluşturdum. Ancak bir sorun var çektiği verilerde boş olanları 0 olarak çekiyor. Boş olan yerleri boş bırakması için ne yapmak gerekir.
 
ardakose' Alıntı:
Mehmet Bey teşekkür ederim ilginize. İstediğim yapıyı oluşturdum. Ancak bir sorun var çektiği verilerde boş olanları 0 olarak çekiyor. Boş olan yerleri boş bırakması için ne yapmak gerekir.
Genişletmek için tıkla ...

Kodu bununla değiştirir misiniz.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String, STR As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5") <> 0 Then
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6") <> 0 Then
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9") <> 0 Then
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
End If
Cells(STR, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 14) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5") <> 0 Then
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6") <> 0 Then
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9") <> 0 Then
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
End If
Cells(STR, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 19) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5") <> 0 Then
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6") <> 0 Then
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9") <> 0 Then
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
End If
Cells(STR, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 24) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5") <> 0 Then
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6") <> 0 Then
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
End If
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9") <> 0 Then
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
End If
Cells(STR, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 29) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
Application.ScreenUpdating = True
End Sub
 
Ben kodları aşağıdaki gibi düzenlemiştim istediğim başka verileri çekmek için.
Gönderdiğiniz kodlara bakarak düzenlemeye çalıştım 0 çıkmaması için ama olmadı.
Aşağıdaki kodları nasıl düzenlemem gerekir.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String, STR As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
Cells(6, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R10C4")
Cells(10, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R10C10")
Cells(11, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R11C10")
Cells(13, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R13C10")
Cells(7, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R16C2")
Cells(8, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R5C2")
End If
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(41, "C").End(xlUp).Row
Cells(STR, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C4")
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
Cells(STR, 7) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C7")
Cells(STR, 8) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C8")
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
Cells(STR, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 14) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
Cells(6, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R10C4")
Cells(7, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R16C2")
Cells(8, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R5C2")
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(41, "C").End(xlUp).Row
Cells(STR, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 19) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
Cells(6, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R10C4")
Cells(7, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R16C2")
Cells(8, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R5C2")
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(41, "C").End(xlUp).Row
Cells(STR, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 24) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
Cells(6, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R10C4")
Cells(7, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R16C2")
Cells(8, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R5C2")
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(41, "C").End(xlUp).Row
Cells(STR, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 29) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
Application.ScreenUpdating = True
End Sub
 
Yazdığım koda dikkatli bakın. Ben ekleme yapmışım.
 
Evet aşağıdaki şekilde eklemeler yapmışsınız.
Kod: 
If Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9") <> 0 Then
Bende yukarda gönderdiğim kodlara bu eklemeleri düzenleyerek ekledim.
Ancak hata verdiği için yaptığım eklemeleri silerek gönderdim.
Gözden kaçırdığım bi yer var sanırım. Akşam tekrar deneyip sonucunu bildiririm.
Şuan işte olduğum için tam dikkat veremiyorum.
Saygılarımla.
 
Evet sakin kafayla kodları düzenledim ve kodlar sorunsuz çalışıyor.
Listemin birinde istediğim bütün özellikler sayenizde oldu sağolun.
Ekte daha önce kod yazdığınız liste var. Burda her tıklamada sürekli hata penceresi çıktığı için
işimi baya zorlaştırıyor. Bu kodların tıklamayla değilde butonla çalışmasını nasıl sağlayabiliriz.
A kolonundaki bir hücreye tıklayıp aç düğmesine tıkladığımızda kolonda yazan isimli dosyayı açmak, güncelle butonuna baştığımda ise sağındaki değerleri güncellemesini sağlamak istiyorum.
 

Ekli dosyalar

Merhaba
Sayfanızdaki kodları bununla değiştirip deneyin.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim YOL As String
YOL = ThisWorkbook.Path & "\"
Workbooks.Open (YOL & activecell.Text & ".xlsx")
End Sub
Private Sub CommandButton2_Click()
Dim YOL As String
YOL = ThisWorkbook.Path & "\"
Cells(activecell.Row, "B") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R1C2")
Cells(activecell.Row, "C") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R2C2")
Cells(activecell.Row, "D") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R3C2")
Cells(activecell.Row, "E") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R4C2")
Cells(activecell.Row, "F") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R5C2")
Cells(activecell.Row, "G") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R6C2")
Cells(activecell.Row, "H") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R7C2")
Cells(activecell.Row, "I") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R8C2")
Cells(activecell.Row, "J") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R9C2")
Cells(activecell.Row, "K") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R10C2")
Cells(activecell.Row, "L") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R11C2")
Cells(activecell.Row, "M") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R12C2")
Cells(activecell.Row, "N") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R13C2")
Cells(activecell.Row, "O") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R14C2")
Cells(activecell.Row, "P") = Application.ExecuteExcel4Macro("'" & YOL & "[" & activecell & "]DATA'!R15C2")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim YOL As String
If Target.Column = 15 And Target <> "" Then
If Intersect(Target, Range("O5:O999")) Is Nothing Then Exit Sub
MsgBox WorksheetFunction.VLookup(Target, Sayfa2.Range("A:B"), 2, 0)
End If
If Target.Column = 16 And Target <> "" Then
If Intersect(Target, Range("P5:P999")) Is Nothing Then Exit Sub
MsgBox WorksheetFunction.VLookup(Target, Sayfa2.Range("A:B"), 2, 0)
End If
End Sub
 
Yardımlarınız için çok teşekkür ederim. Sayenizde tam istediğim gibi bir liste oluştu.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst