Benzersiz Verileri Raporlamak

[baydeniro]

Mrhaba arkadaşlar. D sütünunda yer alan ürünlerin isimlerden 1 den fazla olanlar var. Acaba ürünlerden sadece benzersiz olanları RAPOR sayfasına aktarmak mümkün mü ? Yani aynı üründen 1 den fazla yazılı ise, sadece 1 isim olarak yazacak.

 

[Orion1]

Dosyanız hazır.

Sub benzersiz()
Dim i, sat As Long
Sheets("DATA").Select
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
Application.ScreenUpdating = False
Sheets("RAPOR").Range("A2:A65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "D").End(xlUp).Row
    If WorksheetFunction.CountIf(Range("D2:D" & i), Cells(i, "D").Value) = 1 Then
        Sheets("RAPOR").Cells(sat, "A").Value = Cells(i, "D").Value
        sat = sat + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[Haluk]

Benzersiz Data'ların alınmasıyla ilgili olarak başka bir alternatif ektedir....


.

 

[Necdet]

Merhaba,

Alternatif olarak Fonksiyonlarla Çözüm

=İNDİS(Veri;KÜÇÜK(EĞER(KAÇINCI(Veri;Veri;0)=SATIR(DOLAYLI("1:" & SATIRSAY(Veri)));KAÇINCI(Veri;Veri;0);"");SATIR(DOLAYLI("1:"&SATIRSAY(Veri)))))

=INDEX(Veri;SMALL(IF(MATCH(Veri;Veri;0)=ROW(INDIRECT("1:" & ROWS(Veri)));MATCH(Veri;Veri;0);"");ROW(INDIRECT("1:"&ROWS(Veri)))))

Dizi Formül Olduğundan Formül Ctrl+Shift+Enter ile bitirilmelidir.

 

[Haluk]

Necdet bey, ben de fonksiyonlarla ilgili olarak bir alternatif düşünmüştüm ama soru makrolarla ilgili olduğu için o yönde bir alternatif vermiştim.

 

[Orion1]

Başka bir alternatif dağa.

Sub benzersizler()
Dim k As Range, sat As Long
Sheets("DATA").Select
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
Application.ScreenUpdating = False
Sheets("RAPOR").Range("A2:A65536").ClearContents
sat = 2
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For Each k In Sheets("DATA").Range("D2:D" & Cells(65536, "D").End(xlUp).Row)
       If Not .exists(k.Value) Then
            .Add k.Value, Nothing
            Sheets("RAPOR").Cells(sat, "A").Value = k.Value
            sat = sat + 1
        End If
     Next
End With
Application.ScreenUpdating = True
End Sub

 

[Necdet]

Merhaba Haluk Bey,

Bende sizin örneğinizi aldım ve arşivime koydum. Veri tabanı bağlantılarında gerekli olacak.

 

[Haluk]

Necdet bey, rica ederim ...

Evren bey, bence dictionary'in bu konuda (sizin ilk önerinize) çok fazla katkısı yok ... ama çeşit olsun diyorsanız, o başka tabii... :mrgreen:

 

[Orion1]

Necdet bey, rica ederim ...

Evren bey, bence dictionary'in bu konuda (sizin ilk önerinize) çok fazla katkısı yok ... ama çeşit olsun diyorsanız, o başka tabii... :mrgreen:

Haluk Hocam,merhaba.
2nci yazdığım kodda dictionary olmadan kodlar nasıl olmalıdır.

 

[Haluk]

2nci yazdığım kodda dictionary olmadan kodlar nasıl olmalıdır.

Kabaca ..... sizin ilk öneriniz gibi olabilir :mrgreen:

 

[Orion1]

Kabaca ..... sizin ilk öneriniz gibi olabilir :mrgreen:

Hocam merakımı mazur görün.
2nci yazdığım koddada benzersizler listeleniyordu ama.

 

[baydeniro]

Sayın Evren Gizlen, yardımlarınız ve ilginiz için çok teşekkür ederim. İnanın çok makbule geçti, harika bir çözüm oldu. Allah sizlere zeval vermesin, işiniz gücünüz rast gitsin, rızkınız bol olsun. Sağlıcakla kalın.

 

[Haluk]

Evren bey;

Demek istediğimi şöyle açıklamaya çalışayım....

Ben sizin ikinci alternatifinizi test etmiş de değilim.... (muhtemelen sorunsuz çalışıyordur düşüncesiyle). Burada benim demek istediğim, ortada bir soru var, cevabı da sizin tarafınızdan verilmiş.....

Diğer taraftan, alternatif olarak formüller kullanarak Necdet bey tarafından verilmiş bir cevap üzerine sizin kullandığınız döngülerle hazırlanmış öneriniz üzerine ben de DAO ile bir alternatif verdim.

Eğer sizin daha sonraki alternatifiniz, daha önceki döngü-VBA veya formül yerine .... örneğin yerleşik bir fonksiyon (burada "fonksiyon" ile kastedilen aslında MS Excel'in yerşleşik işlevidir......) olsaydı, bence kayda değer bir alternatif olurdu. Ama, yine klasik VBA .... içinde de fazla bir katkı sağladığını sanmadığım bir "dictionary" olunca, ben o şekilde bir mesaj yazmıştım.

Neyse, bu alakasız mesajları herhalde buradan temizlersiniz, ortalık karıştı ... :mrgreen:

 

[Haluk]

Evren bey, ben size mesaj yazana kadar Serdar bey size cevap yazarak teşekkür emiş.

Sizin cevabınızın haricindeki diğer cevapları (Necdet bey ve benim) göz önüne almadığına göre, biz de Necdet bey ile boşuna çabalamışız.... :mrgreen:

 

[Orion1]

Evren bey, ben size mesaj yazana kadar Serdar bey size cevap yazarak teşekkür emiş.

Sizin cevabınızın haricindeki diğer cevapları (Necdet bey ve benim) göz önüne almadığına göre, biz de Necdet bey ile boşuna çabalamışız.... :mrgreen:

Estafurullah hocam hiç boşuna olurmu.!
Ben sizin alternatif cevabınızı arşivime aldım bile.
Teşekkür ederim.

 

[baydeniro]

Merhaba arkadaşlar. Ben excel.web.tr sitesine karşı öyle bir hayranlık, saygı ve sempati duymaktayım ki bunu kelimeler ile zor ifade edebilirim. Hakikaten sizleri tanıdıktan sonra hem excel'e hayranlığım arttı hem de sizler gibi büyük yeteneklerin var olduğunu bilmekten dolayı ayrıca memnun oldum, gurur duydum.

Sayın Haluk, sizin tarafınızdan üretilmiş bir çözümü göz ardı etmek gibi bir niyetim asla olamaz. Sadece sayın Evren Gizlen'in çözümünden sonra daha başka çözümler olduğunu fark edemedim. Bu çözümü uygulayıp sonucunu gördükten sonra kendisine olan minnettarlığımı hiç zaman geçirmeden yazmak istedim. Sizin yazdıklarınızı daha sonra fark ettim.

Haluk Bey sizin büyüklüğünüz bizim gibi biçarelerin takdirinin kat be kat üstünde. Ama bir hatam olduysa, samimiyetle özür dilerim. Sizlerin katkısına daima ihityacımız var. Sizlerin yansıttığı ışık olmazsa biz karanlıkta kalırız.

Tüm forum üyelerine selamlar, hepiniz sağlıcakla kalın.

EN BÜYÜK TÜRKİYE - ALLAH MUSTAFA KEMAL'İN MEKANINI CENNET EYLESİN

 

[Haluk]

Estağfurullah Serdar bey, büyüklük Allah'a mahsustur.

Özür dilenecek bir şey yok, o an içimden öyle gelmiş sadece....

Kolay gelsin.