Kapali dosyadan Belirli verileri almak

[Ahmet ÖZGÜR]

Merhaba,

Sitede aradım bana uygun bir konu bulamadım ekte vermiş olduğum excel dosyalarında.

Açık excel dosyasında ceki sayfasındaki A3 ve I3 hücrelerindeki verileri kapalı dosyasındaki sayfa1 de Q ve R stünlarında arayacak bulursa kapalıdaki Q hücresindekini açık dosyasındaki ceki sayfasında I2 ye yazacak R hücresinde bulugunu da A4 hücresine yazacak.

Ve kapalı dosyasında sayfa 2 deki veriler arasında b hücresindeki veriyi acık dosyasındaki ceki sayfasında a3 de yazan veriye göre bulacak. Ceki sayfasındaki a5 e yazacak kapalı sayfa s de d hücresinde bulduğunuda acık ceki sayfasındaki e2 hücresine yazacak.


Biraz karışık oldu sanırım ama kusura bakmayın.

 

[Ahmet ÖZGÜR]

sanırım cevap alamayacagım

 

[PLİNT]

Merhaba
Örnek dosyalarınızı burayada ekleyip adres verirmisiniz?http://s3.dosya.tc/

 

[Ahmet ÖZGÜR]

erhan462]çözüm bulamazsanız ücret karşılığında ilgilenebilrim. Kolay gelsin.

Teşekkürler.

Burasını yardımlaşma yeri bilgi öğretme, bilgi alış veriş yapılan bir yer olarak biliyorum.

Ücret karşılığı yaptıracak olsam farklı bir yol izlerim.

İyi Akşamlar.

 

[Ahmet ÖZGÜR]

Merhaba Sayın PLİNT

Link burada buyurun

http://s3.dosya.tc/server6/q8bg84/deneme.rar.html

 

[Ahmet ÖZGÜR]

Sayın PLİNT birde sorum olacak.
Bu eklediğim excel sayfalarının sayfa1 olanı excel den bağlantı yaptım sayfa2 olanı ise sql den çektim.

Ben bu excel dosyasını açtığımda bağlantı yaptığım excel de kişi çalışamıyor. Çalışma kitabını paylaştırdım sorun çözülmedi?

 

[PLİNT]

Açık excel dosyasında ceki sayfasındaki A3 ve I3 hücrelerindeki verileri kapalı dosyasındaki sayfa1 de Q ve R stünlarında arayacak bulursa kapalıdaki Q hücresindekini açık dosyasındaki ceki sayfasında I2 ye yazacak R hücresinde bulugunu da A4 hücresine yazacak.

Merhaba ek dosyayı inceleyin.
http://s3.dosya.tc/server6/s06ads/deneme2.zip.html
Yukarıda "R" hücresi demişsiniz ama örneğinize göre "T" olması gibiydi
değilse kodlaradaki aşağıdaki bölümü düzeltirsiniz.

 [A4] = hz.Sheets("Sayfa1").Range("T" & c.Row)

Ben bu excel dosyasını açtığımda bağlantı yaptığım excel de kişi çalışamıyor

Örneğinizde bir bağlantı görünmüyor.
Bağlantıları menü çubuğu "Veri" sekmesinden bakabilir,kaldırabilirsiniz.
Bahsettiğiniz "sayfa1" içinde ilgili sayfada aşağıdaki kodu uygulayıp deneyin.

 Private Sub CommandButton1_Click()
UsedRange.Value = UsedRange.Value
End Sub

Yukarıdaki ek dosyada bulunan kodlar:

Private Sub CommandButton1_Click()
Dim Aç As Application:  Dim sz As Object
Dim hz As Workbook
Dim hzr As Long: Dim c As Range
Dim xKontrol, ilk, ilk2 As String
Set sz = CreateObject("scripting.dictionary")
On Error Resume Next
Set Aç = New Excel.Application
Aç.Workbooks.Open ThisWorkbook.Path & "\kapalı.xlsx"
Set hz = Aç.Workbooks("kapalı.xlsx")
hzr = hz.Sheets("Sayfa1").Cells(hz.Sheets("Sayfa1").Rows.Count, "R").End(3).Row
xKontrol = Empty
Set c = hz.Sheets("Sayfa1").Range("Q2:Q" & hzr).Find(Trim([A3].Value), LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
ilk = c.Address
Do
If Not sz.exists(c.Row) Then sz.Add c.Row, ""
Set c = hz.Sheets("Sayfa1").Range("Q2:Q" & hzr).FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> ilk
End If
Set c = Nothing
Set c = hz.Sheets("Sayfa1").Range("R2:R" & hzr).Find(Trim([I3].Value), LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
ilk2 = c.Address
Do
If sz.exists(c.Row) = True Then xKontrol = "bulundu": Exit Do
Set c = hz.Sheets("Sayfa1").Range("R2:R" & hzr).FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> ilk2
End If
If Err > 0 Then MsgBox "BİR HATA BULUNDU KONTROL EDİNİZ.": Err = 0
If xKontrol = "bulundu" Then
[I2] = hz.Sheets("Sayfa1").Range("s" & c.Row)
[A4] = hz.Sheets("Sayfa1").Range("T" & c.Row)
End If
If xKontrol = "" Then MsgBox "Sayfa1 de veri bulunamadı"
Set c = Nothing: hzr = 0
hzr = hz.Sheets("Sayfa2").Cells(hz.Sheets("Sayfa2").Rows.Count, "B").End(3).Row
Set c = hz.Sheets("Sayfa2").Range("A2:A" & hzr).Find([A3].Value, Lookat:=xlWhole)
If Not c Is Nothing Then
[A5] = hz.Sheets("Sayfa2").Cells(c.Row, "B")
[E2] = hz.Sheets("Sayfa2").Cells(c.Row, "D")
End If
hz.Close SaveChanges:=True
Aç.Quit
Set Aç = Nothing: Set hz = Nothing: Set sz = Nothing
End Sub

 

[Ahmet ÖZGÜR]

açıktaki I2 E BAKIP KAPALIDAKİ SAYFA 1 IN S STUNUNDA ARAMA YAPMALI

 

[Ahmet ÖZGÜR]

If xKontrol = "bulundu" Then
[COLOR=[I2]= hz.Sheets("Sayfa1").Range("S" & c.Row)
[A4] = hz.Sheets("Sayfa1").Range("T" & c.Row)
End If

"S" Olarak değiştirince tamamdir.

Teşekkür Ederim PLİNT deniyorum detaylı olarak.

 

[Ahmet ÖZGÜR]

Ellerine sağlık şahane olmuş bu arada haklısın "r" ve "t" stünlarında bir karmaşa yapmışım.

Teşekkürler PLİNT.

 

[PLİNT]

Rica ederim, kolay gelsin
Kodları incelediğinizde nerede ne yaptığını anlayacaksınız.

 

[Ahmet ÖZGÜR]

Sayın PLİT,

Anlamaya çalışacağım. Teşekkürler.

 

[Ahmet ÖZGÜR]

Merhaba,
Sayfadan veri alıyor ama ilk satırdakileri alıyor altındaki satırda "0" olanların değerlerini bulunamadı diye döndürüyor.

Veri alınan dosyam baya uzunca.

http://www.dosya.tc/server5/g53yss/excel_ahm.jpg.html

 

[PLİNT]

Merhaba,
Sayfadan veri alıyor ama ilk satırdakileri alıyor altındaki satırda "0" olanların değerlerini bulunamadı diye döndürüyor.

Veri alınan dosyam baya uzunca.

Merhaba
Haklısınız ilk aramada bulduğu satır no larını diziye aldıramamışız,
önceki (7.mesajdaki) kod ve dosyalar değişti onları deneyin.
http://s3.dosya.tc/server6/s06ads/deneme2.zip.html
Yalnız; örnek "kapalı" dosyanızda: mesela "Q" ve "R" sütunlarının 2. satırlarında
"0" ve "68567-45" bulunuyor alt satırda bunlar yanyana tekrarlanıyorsa
ilk bulduğu satırı yani 2. satırı alacaktır.

 

[Ahmet ÖZGÜR]

Sayın PLİNT,
Bu veri aldığım dosya başka bir excel dosyasına bağlı. Ondan 0 atıyor ben o dosyayı düzenliyorum.

Henüz deneyemedim deneyip bilgi vereceğim

Teşekkürler.

 

[PLİNT]

Sayın PLİNT,
Bu veri aldığım dosya başka bir excel dosyasına bağlı.

O zaman aranan kriterlere uyan diğer alttaki satırları bir "listbox" alıp
istenen satırın seçilmesi gerekir.

 

[Ahmet ÖZGÜR]

Anladım diyemem ama isterseniz. Bir örnek gösterebilirsiniz.

 

[Ahmet ÖZGÜR]

Ben onun için yukarda olan veriyi aşağıdaki boş alanlara kopyala gibi bir makro bulmuşrum onu çalşıtırmayı düşünüyorum.

bunun gibi;

Sub üstü_alta_kopyala_1967()
'Konu       :   Üstteki Dolu Satırı Boş Satıra Kopyalama
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi As Long
For asi = 4 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(asi, "C") <> "Member:" And Cells(asi, "C") <> "Distribution:" Then
If Cells(asi, "C") = "Period:" Then asi = asi + 2
If Cells(asi, "C") = Empty Then
Cells(asi, "C") = Cells(asi - 1, "C")
End If
End If
Next
MsgBox "İşlem Tamamlandı", vbInformation, "AhmetOZGUR"
End Sub

 

[Ahmet ÖZGÜR]

PLİNT,

Teşekkürler. İyi Geceler

 

[PLİNT]

Sanırım ben anlatamadım,
http://s3.dosya.tc/server6/ak7phd/satir.JPG.html
Resimdeki sarı işaretli iki satırda "q","r" ve "s" sütunlarındaki veriler aynı
bunun gibi olması halinde üst satırdaki "T" sütunundaki "Jade" alınacaktır
böyle tekrar ihtimali yoksa veya ilk bulunanın getirilmesinde bir sakınca yoksa; sıkıntıda yok değişen kodlar "0" değerlerinide bulacaktır.