Benzersiz veri Listeleme

[seddur]

Merhaba. Liste sayfası"B" sutununda ürün isimleri var.Bu isimleri aynı ürün ismi tekrarlamayacak şekilde Döküm sayfası B14:B18 aralığında listeleyecek 15'den fazla ürün varsa "D" sutununa geçerek Kalan ürün isimlerini D418 aralığında listelemeye devam edecek kodlara ihtiyacım var.Yardımcı olabilirseniz sevinirim.

 

[Greenblacksea53]

Merhaba benzersiz b14 :b18 arasına 15 tane ürün nasıl sığacak ?

 

[seddur]

Ben belli tarihe göre süzme yaptıracağım o yüzden ürün çeşidinin 30 adeti geçmeyeceğini düşünüyorum.

 

[Greenblacksea53]

Sub Yapistir()

Dim hucre As Range
Dim InputRng As Range, OutRng As Range
Set dt = CreateObject("Scripting.Dictionary")
xTitleId = "GreenBlacksea53"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Yapıştıracağın sutünü seç:", xTitleId, Type:=8)
For Each hucre In InputRng
    If hucre.Value <> "" Then
        dt(hucre.Value) = ""
    End If
Next
OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys)
End Sub

Mödüle ekle kodları B sutünda yapıştırmak istediğin verileri seç, Örnek B1:b15 sonra ok deyip yapıştırmak istediğin yere yapıştır Örnek D1

 

[seddur]

Anladım ama dediğim gibi tarihe göre süzme yapacağımız için ürün isimleri farklı farklı satırlarda yer aldığından kopyala yapıştır metodu uygulamak zor olur.

 

[seddur]

Basit gibi gözüküyor ama bir türlü yapamadım.Ekteki dosyada Liste sayfası "B" sutunundaki verileri aynı ürün cinsleri tekrarlamayacak şekilde Döküm sayfası B2:B17 aralığına,bu aralık dolduktan sonra "D" sutununa geçerek D217 aralığına listelemek istiyorum.Yardımcı olursanız sevinirim.

 

[ÖmerFaruk]

Aşağıdaki kodu boş bir module içine ekleyip çalıştırabilirsiniz.
Not: Döküm sayfanızda tüm sütunları kullandım. Eğer döküm sayfasındaki tablonuz sadece E sütununa kadar gidecek ve sağında kalan sütunları başka amaçla kullanıyorsanız kodda ufak bir değişiklik yapmak gerek.

Sub Listele()
   Dim Arr, Dict As Object, Sh1 As Worksheet, Sh2 As Worksheet, Hedef As Range
   Set Sh1 = Worksheets("liste")
   Set Sh2 = Worksheets("Döküm")
   Set Dict = CreateObject("Scripting.Dictionary")
   Arr = Sh1.Range("A1:E" & Sh1.Range("A1").End(xlDown).Row).Value
   If UBound(Arr) < 2 Then Exit Sub
   ReDim Liste(1 To UBound(Arr), 1 To 2)
   Set Hedef = Sh2.Range("B2")
   Hedef.Offset(1, 0).Resize(Rows.Count - Hedef.Row, Columns.Count - Hedef.Column).ClearContents
   For i = 2 To UBound(Arr)
      If Not Dict.Exists(Arr(i, 2)) Then
         Dict.Add Arr(i, 2), Arr(i, 5)
      Else
         Dict(Arr(i, 2)) = Dict(Arr(i, 2)) + Arr(i, 5)
      End If
   Next i
   For i = 0 To Dict.Count - 1
      Say = Say + 1
      If Say > 15 Then Set Hedef = Hedef.Offset(0, 2): Say = 1
      Hedef.Offset(Say, 0) = Dict.Keys()(i)
      Hedef.Offset(Say, 1) = Dict.Items()(i)
   Next i
End Sub

 

[seddur]

Evet. Döküm sayfası E sutununun sağında kalan sutunları başka amaçla kullanıyorum.

 

[ÖmerFaruk]

B2:E17 arasını kullandım sadece
Bu durumda döküm sayfasında maksimum 30 ürün listeleyeceksiniz diye anladım ve onu da ekledim. fazla varsa listelenmeyecektir.

Sub Listele()
   Dim Arr, Dict As Object, Sh1 As Worksheet, Sh2 As Worksheet, Hedef As Range
   Set Sh1 = Worksheets("liste")
   Set Sh2 = Worksheets("Döküm")
   Set Dict = CreateObject("Scripting.Dictionary")
   Arr = Sh1.Range("A1:E" & Sh1.Range("A1").End(xlDown).Row).Value
   If UBound(Arr) < 2 Then Exit Sub
   ReDim Liste(1 To UBound(Arr), 1 To 2)
   Set Hedef = Sh2.Range("B2")
   Hedef.Offset(1, 0).Resize(4,15).ClearContents
   For i = 2 To UBound(Arr)
      If Not Dict.Exists(Arr(i, 2)) Then
         Dict.Add Arr(i, 2), Arr(i, 5)
      Else
         Dict(Arr(i, 2)) = Dict(Arr(i, 2)) + Arr(i, 5)
      End If
   Next i
   For i = 0 To WorksheetFunction.Min(29,Dict.Count - 1)
      Say = Say + 1
      If Say > 15 Then Set Hedef = Hedef.Offset(0, 2): Say = 1
      Hedef.Offset(Say, 0) = Dict.Keys()(i)
      Hedef.Offset(Say, 1) = Dict.Items()(i)
   Next i
End Sub