• DİKKAT

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

Aradığım Değer ve Ona Bağlı A,B,C,D verilerini getirme

mskkaya01

Altın Üye
Katılım
11 Nisan 2020
Mesajlar
13
Excel Vers. ve Dili
2007
Merhaba

firmaya ait araçlara birden fazla kişiler biniyor.
Hangi araca kimler bindi, kimler hangi tarihte kaç litre yakıt altı ve yakıtın tutarı.
I2 hücresine araç plakası yazdığım zaman yukarıda anlatmış olduğum verileri sağ tarafta bulunan
(J, K, L, M, N) sütunlarına gelmesini istiyorum. (excel dosyasında detaylı anlattım)
macro olmazsa sevinirim.

şimdiden herkese teşekkkür ederim.
 

Ekli dosyalar

Merhaba,

Benzer bir konu var yardımcı olması açısında paylaşıyorum;


Kendine göre kodları alır ve yerleştirirsin kendi projene.

İyi çalışmalar.
 
öncelikle çok teşekkür ederim macro çalışamıyorum, aynı çalışmayı buldum kendime göre tasarladım çokta başarılı lakin oda macrolu
 

Ekli dosyalar

Merhaba,
Yardımcı olan olmassa ki olur :)
Müsait olmam durumunda hazırlar paylaşırım.
Benimde pek bilgim yoktu ama kurcalayı kurcalayı az buçuk öğrendik :)
Hayırlı akşamlar.
 
Verdiğiniz dosya özelinde

J3 hücrenize yapıştırın.
=EĞERHATA(İNDİS(C:C;KÜÇÜK(EĞER($B$2:$B$9999=$I$2;SATIR($B$2:$B$9999);"");SATIR(A1)));"")
K-L-M sütunlarına ve aşağı doğru sürükleyerek çoğaltabilirsiniz.

N3 hücrenize de aşağıdaki formülü kullanabilirsiniz
=TOPLA(M3:M20)
 
Verdiğiniz dosya özelinde

J3 hücrenize yapıştırın.
=EĞERHATA(İNDİS(C:C;KÜÇÜK(EĞER($B$2:$B$9999=$I$2;SATIR($B$2:$B$9999);"");SATIR(A1)));"")
K-L-M sütunlarına ve aşağı doğru sürükleyerek çoğaltabilirsiniz.

N3 hücrenize de aşağıdaki formülü kullanabilirsiniz
=TOPLA(M3:M20)

Merhaba Ömer bey yardımlarınız için teşekkür ederim, kodları uyguladım lakin hiç bir şey gelmedi

235455
 
Ekte formülle listeleme çalışması yaptım, incelersiniz.
 

Ekli dosyalar

Dosyayı görmem lazım.
 
Formülde 3 olan kısımları 2 olarak değiştirin .Örnek LIST!$B$3:$B$1000 değil LIST!$B$2:$B$1000 olacak

Rapor sayfası B2 hücresi için

Kod:
=EĞER(SATIRSAY($A$2:A2)<=$H$1;İNDİS(LIST!$B$2:$B$1000;KÜÇÜK(EĞER(LIST!$A$2:$A$1000=$A$1;SATIR(LIST!$A$2:$A$1000)-SATIR(LIST!$A$2)+1);SATIRSAY($A$2:A2)));"")

diğerlerini de buna göre düzeltirsiniz.
 
Formülde 3 olan kısımları 2 olarak değiştirin .Örnek LIST!$B$3:$B$1000 değil LIST!$B$2:$B$1000 olacak

Rapor sayfası B2 hücresi için

Kod:
=EĞER(SATIRSAY($A$2:A2)<=$H$1;İNDİS(LIST!$B$2:$B$1000;KÜÇÜK(EĞER(LIST!$A$2:$A$1000=$A$1;SATIR(LIST!$A$2:$A$1000)-SATIR(LIST!$A$2)+1);SATIRSAY($A$2:A2)));"")

diğerlerini de buna göre düzeltirsiniz.

hocam özür dileyerek, beceremedim
 
ali hocam merhaba
veri tabanındaki kişi sayısı çoğaldıkça sorun olmaya başladı
filtreyi büyükten küçüğe yapınca arama yapmıyor
 
Bence makro kullanmaktan korkmayın. Büyük verilerde makro daha kolay işlem yapar. Örneğin aşağıdaki kodları Rapor sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırırsanız A1 hücresini değiştirdiğinizde istediğiniz sonucun çok hızlı bir şekilde elde edildiğini görebilirsiniz:

PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
eski = Cells(Rows.Count, "A").End(3).Row
son = Sheets("LIST").Cells(Rows.Count, "A").End(3).Row
If eski > 1 Then Range("A2:E" & eski).ClearContents
If Target = "Tüm Liste" Then
    Sheets("LIST").Range("A2:E" & son).Copy [A2]
ElseIf Target <> "" Then
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
   
    sorgu = "select * from [LIST$A:E] where KATEGORİ='" & Target & "'"
    Set rs = con.Execute(sorgu)
   
    [A2].CopyFromRecordset rs
End If
End Sub
 
Bence makro kullanmaktan korkmayın. Büyük verilerde makro daha kolay işlem yapar. Örneğin aşağıdaki kodları Rapor sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırırsanız A1 hücresini değiştirdiğinizde istediğiniz sonucun çok hızlı bir şekilde elde edildiğini görebilirsiniz:

PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
eski = Cells(Rows.Count, "A").End(3).Row
son = Sheets("LIST").Cells(Rows.Count, "A").End(3).Row
If eski > 1 Then Range("A2:E" & eski).ClearContents
If Target = "Tüm Liste" Then
    Sheets("LIST").Range("A2:E" & son).Copy [A2]
ElseIf Target <> "" Then
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
  
    sorgu = "select * from [LIST$A:E] where KATEGORİ='" & Target & "'"
    Set rs = con.Execute(sorgu)
  
    [A2].CopyFromRecordset rs
End If
End Sub
tşk ederim hocam deniyeceğim
 
Geri
Üst