benzersiz değerleri farklı sayfada süzme

[garatemur]

Mehaba,

Bir sayfada a ve u sütunları arasında 2000 satır lık veriler var
bu verilerin içinde ; a,c,h,l,u sütunlarındaki benzersiz verileri yeni bir sayfada listelemek için nasıl bir macro kullanabilirim ?

yani a,c,h,l,u sütunlarını bir sütunda birleştirip bu birleştirmeyi alt satırlara uygulayıp verilerin birleştirildiği satırları eğersay ile benzersileri listeliyor daha sonra düşey ara ile bunlara tekrar yeni sayfada sütunlara bölüp benzersiz değerleri çıkarıyordum. bunu macro ile yapmak istiyorum formül ile dosya çok şişiyor.

 

[Orion1]

Mehaba,

Bir sayfada a ve u sütunları arasında 2000 satır lık veriler var
bu verilerin içinde ; a,c,h,l,u sütunlarındaki benzersiz verileri yeni bir sayfada listelemek için nasıl bir macro kullanabilirim ?

Forumda scripting.dictionary diye arama yapınız.

 

[garatemur]

yaptım fakat sonuç alamadım konu yok

 

[garatemur]

macro yazmada yeniyim yardımcı olursanız çok sevinirim
çoklu yinelenenleri kaldır ın macro ile yapılışını arıyorum

 

[Orion1]

Örnek dosya yüklerseniz , sonucu daha çabuk alabilirsiniz.

 

[garatemur]

Biraz geç oldu kusura bakmayın örnek dosya ektedir

 

[Orion1]

Biraz geç oldu kusura bakmayın örnek dosya ektedir

Örnek dosya yok.

 

[garatemur]

Eklemeyi buldum

Şimdiden teşekkürler.

 

[garatemur]

bu şekilde 32 sayfa var hepsinden aynı şekilde liste yapmalıyım

 

[Orion1]

Benzersizler olmuşmu bakın bir.
Dosya linktedir.

DOSYAYI İNDİR

Option Base 1
Sub benzersiz59()
Dim sh As Worksheet, sonsat As Long, liste(), z As Object
Dim myarr(), n As Long, i As Byte, tplsonsat As Long
Dim deg As String
Set z = CreateObject("Scripting.dictionary")
Sheets("STOK DURUMU").Select
Sheets("STOK DURUMU").Range("A2:D" & Rows.Count).ClearContents
For i = 1 To 2
    Set sh = Sheets(i)
    sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
    tplsonsat = tplsonsat + sonsat
    liste = sh.Range("A2:U" & sonsat).Value
    ReDim Preserve myarr(1 To 4, 1 To tplsonsat)
    For j = 1 To UBound(liste)
        deg = liste(j, 1) & liste(j, 3) & liste(j, 8) & liste(j, 21)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add (deg), n
            myarr(1, n) = liste(j, 1)
            myarr(2, n) = liste(j, 3)
            myarr(3, n) = liste(j, 8)
            myarr(4, n) = liste(j, 21)
        End If
    Next j
Next i
Set sh = Sheets("STOK DURUMU")
ReDim Preserve myarr(1 To 4, 1 To n)
Range("A2").Resize(n, 4) = Application.Transpose(myarr)
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[garatemur]

Evet elinize sağlık sorunsuz çalışıyor toplamlarda da yardımcı olursanız süper olacak.

 

[Orion1]

Evet elinize sağlık sorunsuz çalışıyor toplamlarda da yardımcı olursanız süper olacak.

R SÜTUNUNDAKİ TOPLAM SATIŞ KG.


Böyle demişsiniz ama R sütununda rakam yok sayı var.
Yanlış söylediz galiba.Onu tekrar bakın söyleyin.

 

[garatemur]

r sütunundaki satış yazan kalemleriin e sütunu toplamı olacak çok anlaşılır belirtmemişim evet

 

[Orion1]

R SÜTUNUNDAKİ TOPLAM SATIŞ KG.

bu toplanan sayfalardan hangi sütun toplanacak.

 

[Orion1]

R SÜTUNUNDAKİ TOPLAM BOYA SEVK KG.

Bu sayfa2den hangi sütundan alacak.

 

[garatemur]

E sütunuundan alacak

 

[garatemur]

Toplamların hepsi e sütunundan sadece kalan mt F sütunundan

 

[Orion1]

Toplamların hepsi e sütunundan sadece kalan mt F sütunundan

Tamam.

 

[Orion1]

ilk sayfadan son sayfadan bir önceki sayfaya kadar dönüyor,ve topluyor.
Son sayfada toplamları olan sayfa olmalı daima.
Dosyanız ektedir.

Option Base 1
Sub benzersiz59()
Dim sh As Worksheet, sonsat As Long, liste(), z As Object
Dim myarr(), n As Long, i As Byte, tplsonsat As Long
Dim deg As String
Set z = CreateObject("Scripting.dictionary")
Sheets("STOK DURUMU").Select
Sheets("STOK DURUMU").Range("A2:I" & Rows.Count).ClearContents
For i = 1 To Worksheets.Count - 1
    Set sh = Sheets(i)
    sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
    tplsonsat = tplsonsat + sonsat
    liste = sh.Range("A2:U" & sonsat).Value
    ReDim Preserve myarr(1 To 9, 1 To tplsonsat)
    For j = 1 To UBound(liste)
        deg = liste(j, 1) & liste(j, 3) & liste(j, 8) & liste(j, 21)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add (deg), n
            myarr(1, n) = liste(j, 1)
            myarr(2, n) = liste(j, 3)
            myarr(3, n) = liste(j, 8)
            myarr(4, n) = liste(j, 21)
        End If
        myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + liste(j, 5)
        If liste(j, 18) = "SATIŞ" Then myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + liste(j, 5)
        If liste(j, 18) = "BOYA" Then myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + liste(j, 5)
        If liste(j, 18) = "" Then myarr(8, z.Item(deg)) = myarr(8, z.Item(deg)) + liste(j, 5)
        If liste(j, 18) = "" Then myarr(9, z.Item(deg)) = myarr(9, z.Item(deg)) + liste(j, 6)
    Next j
Next i
Set sh = Sheets("STOK DURUMU")
ReDim Preserve myarr(1 To 9, 1 To n)
Range("A2").Resize(n, 9) = Application.Transpose(myarr)
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[garatemur]

Çok teşekkür ederim emeğinize sağlık