Coklu veri cekme

[ozakpolat]

Merhaba,

Bu konuyu forumda cok aradim fakat bulamadim yardimci olbilirseniz cok sevinirim.

Ben düsey ara ile arattigimda birden cok deger cikiyor, cikan degerleri tek hücreye yazmasini istiyorum yapamadim birtürlü yardimci olurmusunuz lütfen. örnekteki g3 hücresine isim girildiginde h4 hücresinde buldugu bütün degerleri yazmasini istiyorum.

 

[asi_kral]

Merhaba
Formül ile bunu yapmak zor. Makro ile isterseniz yardımcı olabilirim.

 

[ozakpolat]

makro ilede olur fakat bu dosyayi örnek olarak hazirladim,aslinda ben baska bir exel dosyasindan veriyi cekmek istiyorum. mümküünmü acaba

 

[ozakpolat]

ben size orjinallerini yollim isterseniz siz bir göz atin daha iyi anliyacaksiniz yapmak istediklerimi.

kabel dosyasindaki R4 hücresine yazilacak formül,A sütününda yazili olan ismi, Datenbank dosyasindaki e stününda arayip ona karsilik gelen B sütünundaki degerleri cekmek istiyorum yapabilirseniz büyük bir yükten kurtaracaksiniz beni. tesekkürler ilginiz icin

 

[asi_kral]

makro ilede olur fakat bu dosyayi örnek olarak hazirladim,aslinda ben baska bir exel dosyasindan veriyi cekmek istiyorum. mümküünmü acaba

Başka bir dosyadan mı veri alacaksınız_?
Doğru anladıysam lütfen iki dosyanızı da ekleyin. Ayrıca veri alacağınız dosyanın adresini de bildirirseniz ona göre düzenleyeyim.
Örneğin :

D:\ozakpolat

Gibi.
İki kitapta aynı yerde olacaksa o zaman adres bildirmenize gerek yok.

 

[ozakpolat]

ayni yerde olacak dosyalar, dosyalari ekledim tesekkürler

 

[asi_kral]

Merhaba
1. İki dosyanızda dıştan veri alıyor.
2. Bu dosyalar çok karışık ne yapılacağını açık anlatmanız gerekli bu dosyalardan ben hiç bir şey anlamadım.
Dosyanın içinde örnek verecek açıklarsanız yardımcı olamaya çalışacağım.

 

[ozakpolat]

basitlestirebildigim kadar basitlestirdim tekrar bakabilirmisiniz

 

[asi_kral]

Merhaba
Datenbank1'deki dış dosya bağlantısını iptal edin.
Kabel dosyasında boş bir module oluşturun ve içerisine bu kodu kopyalayın.

Option Explicit
Sub veri_çek_birleştir()
Dim EX As Application, KTP As Workbook, S1 As Worksheet
Dim S2 As Worksheet, BUL As Range, SBT As Variant
Dim STR As Long, VR As String, YOL As String
Set EX = CreateObject("Excel.Application")
EX.Visible = False
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
Set S1 = ActiveWorkbook.ActiveSheet
Set KTP = EX.Workbooks.Open(YOL & "Datenbank1.xlsm")
Set S2 = KTP.ActiveSheet
For STR = 4 To S1.Cells(Rows.Count, "A").End(xlUp).Row
Set BUL = S2.Range("C:C").Find(S1.Cells(STR, "A"), , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If VR = Empty Then
VR = S2.Cells(BUL.Row, "B")
Else
VR = VR & " - " & S2.Cells(BUL.Row, "B")
End If
Set BUL = S2.Range("C:C").FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
S1.Cells(STR, "B") = VR
VR = Empty
Next
KTP.Close: EX.Quit
Application.ScreenUpdating = True
End Sub

Kodu deneyin sonuçları gözlemleyin.
Not : Dosyayı kaydederken makro içerebilen dosya ( .xlsm ) şeklinde kayıt yapınız.

 

[ozakpolat]

cok tesekkürler sagolun