Farklı Kolonlardaki Kayıtları Benzersiz Alma

[Fuat Şirin]

Sub etopla()
Sheets("STOK").Range("a:H").ClearContents
Sheets("KESİM").Columns("B:L").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("STOK").Range("a1"), Unique:=True
son = Sheets("STOK").[a65536].End(3).Row
For t = 2 To son
    giren = Evaluate("=SumProduct((KESİM!B2:B5000=" & Cells(t, 1).Address & ")*(KESİM!I2:I5000=" & Cells(t, 2).Address & ")*(KESİM!J2:J5000=" & Cells(t, 3).Address & ")*(KESİM!K2:K5000=" & Cells(t, 4).Address & ")*(KESİM!L2:L5000))")
    cikan = Evaluate("=SumProduct((DİKİM!C2:C5000=" & Cells(t, 1).Address & ")*(DİKİM!F2:F5000=" & Cells(t, 2).Address & ")*(DİKİM!G2:G5000=" & Cells(t, 3).Address & ")*(DİKİM!E2:E5000=" & Cells(t, 4).Address & ")*(DİKİM!H2:H5000))")
    kalan = giren - cikan
    Sheets("STOK").Cells(t, 6) = kalan
    Next
End Sub

bu kodları kullanarak stok takibi yapmaya çalışıyorum
ama takıldığım biyer var benzersiz almak istediğim aralık bitişik değil
("B:L") olarak değilde
yani bu şekilde;
B, I , j , K , L
sutunklarını benzersiz almak istiyorum

 

[Recep İpek]

Küçük örnek bir dosya ekleyebilirmisiniz?

 

[Fuat Şirin]

dosya ektedir

hocam sarı olan sütunları listelemicek yani benzersi olarak almıcak
kırmızı olan sütundada benzersiz olanları toplıcak
koşul 4 koşul yani , 4 koşula göre toplama

 

[Fuat Şirin]

dosya ekte

hocam bu açıklayıcı olduğu kanatindeyim
sarı olan alanlar koşul pembe olan alanlar ise toplanacak

yani dört koşula göre pembe olan yerleri toplıcak stok sayfasında

c300/ erkek atlet / beyaz / 8 = 100 gibi

stok sayfasında benzersiz olarak listelemem lazım

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

STOK sayfasında başka kolonları da görmek isterseniz ekleyebiliim.

Sub AktarTopla()
'www.excel.web.tr / ripek
Dim a, b, c, d, i, n, z, veri()
Set s1 = Sheets("KESİM")
Set s2 = Sheets("DİKİM")
Set s3 = Sheets("STOK")
'*******************************************
a = s1.Range("a2:m" & s1.[a65536].End(3).Row).Value
b = s2.Range("a2:m" & s2.[a65536].End(3).Row).Value
d = s1.[a65536].End(3).Row + s2.[a65536].End(3).Row
ReDim veri(1 To d, 1 To 6)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
z = a(i, 2) & ":" & a(i, 9) & ":" & a(i, 10) & ":" & a(i, 11)
If Not .exists(z) Then
n = n + 1
veri(n, 1) = n
veri(n, 2) = a(i, 2)
veri(n, 3) = a(i, 9)
veri(n, 4) = a(i, 10)
veri(n, 5) = a(i, 11)
.Add z, n
End If
veri(.Item(z), 6) = veri(.Item(z), 6) + a(i, 12)
End If
Next i
'***********************************************
For i = 1 To UBound(b, 1)
If Not IsEmpty(b(i, 1)) Then
z = b(i, 3) & ":" & b(i, 5) & ":" & b(i, 6) & ":" & b(i, 7)
If Not .exists(z) Then
n = n + 1
veri(n, 1) = n
veri(n, 2) = b(i, 3)
veri(n, 3) = b(i, 5)
veri(n, 4) = b(i, 6)
veri(n, 5) = b(i, 7)
.Add z, n
End If
veri(.Item(z), 6) = veri(.Item(z), 6) - b(i, 8)
End If
Next i
'***********************************************
End With
s3.Range("a2:g1000").ClearContents
s3.[a2].Resize(n, 6).Value = veri
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
Set s3 = Nothing
End Sub

 

[Fuat Şirin]

hocam tam istediğim
başka kolon eklemek istesek
kod üzerinde renkli olarak belirtebilir misiniz?
bende diğer işlerimde yapayım

 

[Recep İpek]

Dizideki kolon sayısını düzeltmeniz gerekmektedir.

Burada 6 kolon dikkate alınmıştır.

 

[Fuat Şirin]

hocam çok teşekkür ettim büuüyk bir sorunumu çözdünüz