Makro ile 3 Sütundaki değerleri beraber benzersiz sıralama

[Ergün Güler]

Selam,
Ekteki örnek dosyamın "çeşitler" sayfasındaki kodlar ile "insört" sayfasındaki G, I, J sütunlarındaki değerleri birleştirip A sütununda sıralıyorum.
B,C,D sütunlarında ise benzersiz sıralama yapıyorum.

A sütundaki yardımcı hücreleri kullanmadan 3 sütunu beraber benzersiz nasıl sıralayabilirim?

2.sorum;
3'lü benzersiz sırlanan verilerin E sütununda toplam miktarları, F sütununda toplam Adetleri bulmak istiyorum
Nasıl yapabilirim?
Sayfa üzerinde açıklamalar ve örnekler mevcuttur. Yardımcı olabilirseniz çok sevinirim.
İyi çalışmalar.
Kodlarım da aşağıdaki gibidir.

Private Sub CommandButton2_Click()
Dim son, satır As Long
Dim s1, s2 As Worksheet

Application.ScreenUpdating = False

Set s1 = Sheets("insört")
Set s2 = Sheets("Çeşitler")

son = s1.Cells(65536, 1).End(3).Row

satır = 2

For i = 3 To son

a = s1.Cells(i, 7).Value
b = s1.Cells(i, 9).Value
c = s1.Cells(i, 10).Value

s2.Cells(i, 1) = a & b & c
Next

For j = 2 To son

d = s1.Cells(j, 7).Value
e = s1.Cells(j, 9).Value
f = s1.Cells(j, 10).Value

If WorksheetFunction.CountIf(s2.Range("A2:A" & j & ""), d & e & f) = 1 Then
satır = satır + 1
s2.Cells(satır, 2) = d
s2.Cells(satır, 3) = e
s2.Cells(satır, 4) = f
End If

Next

Application.ScreenUpdating = True

End Sub

 

[Orion1]

Dosyanız ektedir.

Sub benzersiz_topla_aktar_59()
Dim conn As Object, rs As Object, sh As Worksheet, sat As Long
Sheets("Çeşitler").Select
Range("A3:E65536").Clear
Set sh = Sheets("insört")
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("AdoDb.Recordset")
sat = sh.Cells(65536, "G").End(xlUp).Row
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=no;imex=1"";"
rs.Open "select first(F1),first(F3),first(F4),sum(F6),count(F1) from [insört$G2:L" & sat & "] group by F1,F3,F4;", conn, 1, 1
Application.ScreenUpdating = False
Range("B3").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close: conn.Close: Set rs = Nothing: Set conn = Nothing
MsgBox "Benzersiz işlemler tamamlanmıştır." & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Ergün Güler]

Dosyanız ektedir.

Sub benzersiz_topla_aktar_59()
Dim conn As Object, rs As Object, sh As Worksheet, sat As Long
Sheets("Çeşitler").Select
Range("A3:E65536").Clear
Set sh = Sheets("insört")
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=no;imex=1"";"
rs.Open "select first(F1),first(F3),first(F4),sum(F6),count(F1) from [insört$G2:L65536] group by F1,F3,F4;", conn, 1, 1
Application.ScreenUpdating = False
Range("B3").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close: conn.Close: Set rs = Nothing: Set conn = Nothing
MsgBox "Benzersiz işlemler tamamlanmıştır." & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

Selam Sayın Evren Gizlen,
ellerinize sağlık çok teşekkür ederim. Bir kaç sorum olacak;
1.si; küçük bir problem var. Şöyle ki,
makroyu çalıştırdığım zaman 3 satırda boş bir bilgi veriyor. verdiğiniz yukarıdaki koddaki

from [insört$G2:L[COLOR="Red"]65536[/COLOR]]

kırmızı kısmını

from [insört$G2:L[COLOR="Red"]171[/COLOR]]

yapınca sorun düzeliyor. Sanırım 171. satırdan sonraki boş bilgileri benzersiz 1 tane olarak sıralıyor.
kodlara

son = sh.cells(65536, 1).End(3).Row

from [insört$G2:L[COLOR="Red"] & son[/COLOR]]

ekedim. Ancak, ilgili satırda hata verdi. Ne yapmamız gerekir?
2.si; çözümünüz aynı zamanda harika bir sıralama yapıyor. önce ebatı, sonra yaprağı sonra gsm sıralıyor
bir kaç düğme daha ekleyerek,
1-normal sırayayla benzersiz aktar (yan benim örnek sıralamam gibi)
2-miktar çokluğuna göre benzersiz aktar
3-adet çokluğuna göre aktar
gibi yapabilir miyiz?

3.sü; yukarıda verdiğiniz kodlarınıza çok yabancıyım. Kodlarınızı ezberlemekten ziyade anlamak istiyorum. Mümkünse biraz anlatabilir misiniz?

4.si; Benim örnek dosyamda yaptığım gibi, A sütunu olmayan aynı metot ile (yani döngü v.s. ile) asıl yapabiliriz?

şimdiden çok teşekkürler
İyi çalışmalar.

 

[Orion1]

Selam Sayın Evren Gizlen,
ellerinize sağlık çok teşekkür ederim. Bir kaç sorum olacak;
1.si; küçük bir problem var. Şöyle ki,
makroyu çalıştırdığım zaman 3 satırda boş bir bilgi veriyor. verdiğiniz yukarıdaki koddaki

from [insört$G2:L[COLOR="Red"]65536[/COLOR]]

kırmızı kısmını

from [insört$G2:L[COLOR="Red"]171[/COLOR]]

yapınca sorun düzeliyor. Sanırım 171. satırdan sonraki boş bilgileri benzersiz 1 tane olarak sıralıyor.
kodlara

son = sh.cells(65536, 1).End(3).Row

from [insört$G2:L[COLOR="Red"] & son[/COLOR]]

ekedim. Ancak, ilgili satırda hata verdi. Ne yapmamız gerekir?
2.si; çözümünüz aynı zamanda harika bir sıralama yapıyor. önce ebatı, sonra yaprağı sonra gsm sıralıyor
bir kaç düğme daha ekleyerek,
1-normal sırayayla benzersiz aktar (yan benim örnek sıralamam gibi)
2-miktar çokluğuna göre benzersiz aktar
3-adet çokluğuna göre aktar
gibi yapabilir miyiz?

3.sü; yukarıda verdiğiniz kodlarınıza çok yabancıyım. Kodlarınızı ezberlemekten ziyade anlamak istiyorum. Mümkünse biraz anlatabilir misiniz?

4.si; Benim örnek dosyamda yaptığım gibi, A sütunu olmayan aynı metot ile (yani döngü v.s. ile) asıl yapabiliriz?

şimdiden çok teşekkürler
İyi çalışmalar.

Sat ile son satırı tanımlayınca boşluk kalktı.
Sanırım orada bir yerlerde veri algılıyor.
Bu kodlar ADO V SQL kodlarıdır.
Dosyaı önceki mesajımdan indirebilirsiniz.
Bunlar çok hızlı çalışırlar.
Beynelmilel kodlardır.
Hemen hemen her programlama dili bu kodları kullanarak işlerini görürler.
Yani veritabanı ile parogram arasındaki işlemleri.
Bu derece hızlı olarak çalışan kod vba iled eyaparım.Ama siz yine onuda anlamayakaksınız diye tahmin ediyorum.
Ondada createobject ve scripting dictionary kullanacam.
Onu sonra yapıcam.
Şimdi az işim var.
Kolay gelsin.

 

[Orion1]

Hem ado ile hemde vba ile çözüm.
2 ayrı butona her 2 kodu atadım.
2side çok hızlı çalışır.
Diğer kodlarla bu kodların arasındaki farkı 500 - 1000 satır arasında kayıtlarda anlayamazssınız.
Ancak kayıt sayısı 30 bin 40 binelere çıktığında bunların farkını anlarsınız.Bu kodlarala 1-3 saniye arasında bitiyorsa işlem .Başka alternatiflerde 2-3 saate kadar çıkabilir.
Her 2 kodlamayıda kullanabilirsiniz.
Yalnız scripting dictionaryde kullandığım resize komutu excel hücresi için 255 max karakter alabiliyor.Fazla olduğunda ise hata veriyor.
Bu durumda scripting dictionary nesnesinden döngüye girip verileri atabilirsiniz.
Diğer sorularınız anlamdım.
Kolay gelsin.

Option Explicit
Option Base 1
Sub vba_ile_benzersiz_topla_aktar()
Dim sh As Worksheet, sat As Long, z As Object, n As Long
Dim liste(), myarr(), i As Long, deg As String
Sheets("Çeşitler").Select
Set sh = Sheets("insört")
sat = sh.Cells(65536, "G").End(xlUp).Row
Range("B3:F65536").ClearContents
If sat < 2 Then Exit Sub
liste = sh.Range("G2:L" & sat).Value
ReDim myarr(1 To 5, 1 To 65536)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste, 1)
    deg = liste(i, 1) & "-" & liste(i, 3) & "-" & liste(i, 4)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 3)
        myarr(3, n) = liste(i, 4)
    End If
    myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 6)
    myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + 1
Next i
Application.ScreenUpdating = False
Range("B3").Resize(n, 5) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "VBA ile Benzersiz kayıtlar toplandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Ergün Güler]

Selam,
Sayın Evren gerçekten harikasınız ellerinize sağlık.
1-) Boşluk sorunu dediğiniz gibi imiş. insört sayfasında herhangi bir değer bulamamama rağmen son dolu satırdan sonraki satırları sildim. dediğiniz gibi 1. satırdaki boş bilgi sorunu düzeldi.

[insört$G2:L" & sat & "]

şeklindeki çözümü de öğrenmem iyi oldu.

2-) Anlayamadım dediğiniz diğer sorularım için, 1.mesajımdaki dosyamı güncelledim. "Çeşitler(2)" sayfasında 4 ayrı sıralama örneği yaptım.
1.si: Normal sıralama yani verilerin alındığı insört sayfasından geldiği gibi (bunu sizin VBA kodlarınız yapıyor.)
2.si: Ebat, sonra yaprak, sonra gsm olarak artan sıralama yapıyor. (bunu sizin ADO kodlarınız yapıyor.)

benim istediğim ise,
3.sü Miktar Azalan sırlaması (ölçüt sadece bir tane olacak oda miktar)
4.sü: Adet Azalan sıralaması (ölçütün 1.si Adet azalan sıralama, 2.si Ebat artan, 3. sü Yapak artan olacak)
Ancak, sayfada ayrı ayrı yaptığım bu sırlamayı 4 ayrı buton ile aynı sütunlarda yapmak istiyorum.
Yardımcı olabilirseniz çok sevinirim. Hatta ADO için ayrı VBA için ayrı yaparsanız çok daha mutlu olurum.

3-) Dediğiniz gibi ilk kodlardan anlamadığım gibi 2.lerden de anlamadım. Ancak, size çok zahmet olmassa ucundan biraz biraz anlatsanız. Veya anlayabileceğim link v.s. verseniz çok iyi olur. Elbette tek seferde kodları öğrenemeyeceğim. Fakat, sizden biraz başka uzmanlardan biraz, sitedeki diğer çözümlerden, örnek dosylardan, derslerden, kodlardan, biraz pekişecektir diye düşünüyorum. Yoksa tamamını anlatınız demiyorum.
mesela ADO için
- CreateObject("ADODB.Connection")
- CreateObject("AdoDb.Recordset")
kısımlarından biraz bahsetseniz ve
VBA için
- ReDim myarr(1 To 5, 1 To 65536)
- CreateObject("Scripting.Dictionary")
- UBound(liste, 1)
kısımlarından bahsetseniz iyi olurdu.
4-) 1.mesajımdaki "insört" ve "üretim" sayfaları için kendim kodlar hazırlamıştım. yine aynı dosya üzerinden farklı konularda soru sormuştum. İlgili sayfaların içinde detaylı açıklamalarım mevcuttur. bu kodlara alternatif fikirler veya kodlar hususunda yardımcı olmak isterseniz bunların için de çok çok memnun olurum.
Şimdiden çok teşekkürler.
İyi çalışmlalar.

 

[Orion1]

Sıralamaları yarın yapıcam.
ADO
Netten arama yapınız.
RECORDSET
Netten arama yapınız.
Redim myarr,ubound(liste,1)
Forumda Dizi diye arama yapınız.
Scripting.Dictionary
Aşağıdaki linki inceleyiniz.
http://www.excel.web.tr/forumdisplay.php?f=166

 

[Orion1]

İstediğiniz sıralamaları yaptım.
Ekli dosyayı inceleyiniz.

 

[Ergün Güler]

İstediğiniz sıralamaları yaptım.
Ekli dosyayı inceleyiniz.

Selam,
Sayın Evren Bey, gerçekten harikasınız. Çok emek vermişsiniz. Çok teşekkür ederim.
Bikaç problem var. Adım Adım anlatıyorum.

1. düğmeler için;
"ADO İLE BENZERSİZ AKTAR" sonuçların 19. ve 42 satırı yer değiştiryor.
Aynı şekilde 42. ve 43. satırları yer değiştiriyor. Ayrıca A sütununda yardımcı hücre kullanılıyor galiba.
"VBA İLE BENZERSİZ AKTAR" düğmesi doğru çalışıyor.

2. düğmeler için;
"ADO İLE BENZERSİZ AKTAR TÜMÜ ARTAN SIRALAMA" sonuçları doğru.
"VBA İLE BENZERSİZ AKTAR TÜMÜ ARTAN SIRALAMA" ise ebat,yaprak,gsm'ler doğru ancak, miktarları ve adetleri doğru değil. Başka satırın bilgileri ile karışmış.

3. düğmeler için;
Düğmelerin ikisi de doğru çalışyor.
4.düğmeler için;
"ADO İLE BENZERSİZ AKTAR ADET AZALAN EBAT ARTAN YAPRAK ARTAN SIRALAMA" ve "ADO İLE BENZERSİZ AKTAR ADET AZALAN EBAT ARTAN YAPRAK ARTAN SIRALAMA" ise GSM ARTAN sıralama da dahil edilirse çok iyi olacaktır.

Şimdiden çok teşekkür ederim.

 

[Orion1]

1-ado ile benzersiz sıralam için ana sayfadaki sıra noları baz aldım.
Fakat ado kendisi ilk anda her 2 satırda eşitse 2nci satıra bakmış ve büyük olanı kendisi sıralam yapıp öne almış.Buna bişey yapamam.O butonda başka problem yok.
2-Durum düzeltildi.
3-problem yok demişsiniz.
4-Ekleme yapıldı.En son sıralamaya dahil edildi.
Ekli dosdyayı bir önceki mesajımdan indirebilirsiniz.

 

[Ergün Güler]

Selam Sayın Evren,
ellerinize sağlık. Çok çok teşekkür ederim. Gerçekten harikasınız.
1. için VBA
2.için ADO (VBA gsm'i artan sıralamaya sokamadığı için kullanmıyorum)
3.için VBA
4.için VBA
kullanacağım.
İyi çalışmalar.

 

[Orion1]

Selam Sayın Evren,
ellerinize sağlık. Çok çok teşekkür ederim. Gerçekten harikasınız.
1. için VBA
2.için ADO (VBA gsm'i artan sıralamaya sokamadığı için kullanmıyorum)
3.için VBA
4.için VBA
kullanacağım.
İyi çalışmalar.

2- VBA gsm'i sıralamyaz olurmu?Elbette sıralar.
Ama ben onu en son sıralamaya tabii tuttum.
yani 3ncü sırada değil.Mutlaka bir anlaşmazlık olmuştur aramızda ya siz anlatamadınız yada ben anlaymadım.Yani sıralayamaz diye bir şey olamaz.

 

[Ergün Güler]

Selam,
Elbette ben anlatamamış olabilirim. Ancaki ADO ile istenileni yapmışsınız zaten. VBA yapamaz demedim. Ki anlayamadığım birşey için yapamaz diyemem.

Sub vba_ile_TUMU_ARTAN_SIRALAMA_benzersiz_topla_aktar_59() başlıklı kodlarınızı inceledim.
Çok fazla anlamıyorum Ancak, aşağıdaki kodların kırmızı kısmında 2 tane key2 olduğunu gördüm.

Application.ScreenUpdating = False
Range("B3").Resize(n, 5) = Application.Transpose(myarr)
Range("B3:F65536").Sort key1:=Range("E3"), order1:=xlAscending, _
key2:=Range("F3"), order1:=xlAscending
Range("B3:F65536").Sort key1:=Range("B3"), order1:=xlAscending, _
key2:=Range("C3"), order2:=xlAscending, key2:=Range("D3"), order3:=xlAscending
Application.ScreenUpdating = True

2.sini key3 yaptım.

key2:=Range("C3"), order2:=xlAscending, key3:=Range("D3"), order3:=xlAscending

sorun düzeldi. Çok çok teşekkür ederim. Ellerinize sağlık. Çok minnettarım size.
İyi çalışmalar.

 

[Orion1]

Selam,
Elbette ben anlatamamış olabilirim. Ancaki ADO ile istenileni yapmışsınız zaten. VBA yapamaz demedim. Ki anlayamadığım birşey için yapamaz diyemem.

Sub vba_ile_TUMU_ARTAN_SIRALAMA_benzersiz_topla_aktar_59() başlıklı kodlarınızı inceledim.
Çok fazla anlamıyorum Ancak, aşağıdaki kodların kırmızı kısmında 2 tane key2 olduğunu gördüm.

2.sini key3 yaptım.


sorun düzeldi. Çok çok teşekkür ederim. Ellerinize sağlık. Çok minnettarım size.
İyi çalışmalar.

Tebrikler.İşi halletmişsiniz.
Baezen bizimde gözümüzden kaçıyor.Ufak bir şey ama gördüğünüz gibi sonucu istenilen gibi vermiyor.
İyi çalışmalar.