• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Aynı kodların toplanmasıyla ilgili bir soru

  • Konbuyu başlatan Konbuyu başlatan izcik
  • Başlangıç tarihi Başlangıç tarihi
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Değerli uzmanlarım, aynı kodlu olan stokları toplayarak ,

tek olanları da aynı kalacak şekilde bir makro oluşturabilir misiniz?

Teşekkür ederim. Saygılar

Not: Problemim 23 satırla sınırlı değildir. Başka zaman yüzlerce binlerce satır olabilmektedir. O yüzden 65536 satır olarak ayarlamanızı rica ederim. (Hata oluşmasın diye.)
 

Ekli dosyalar

Merhaba,

Kod: 
Sub Aktar_Topla()
Range("E2:G65536").ClearContents
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Cells(j, "g") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("C:C"))
Next
End Sub

Detaylı bilgi için,

Mükerrer (Çift) Kayıt Engelleme,Sayma Örnekleri

.
 
Ömer uzmanım çok teşekkürler. Fakat bir iki minik düzeltme yapmamız gerekiyor.

Fiyat kısmını da topluyor. Toplamaması gerekiyor. çünkü toplanmış adet ile mamülün tek fiyatının çarpılması gerekir.

Bir de KUMAŞ RENK KODU yazan A1 deki kısım , makro düğmesine basınca E1 sütununda görünüyor ya,

B1 ve C1 deki yazılanların da aynen F1 ve G1 sütununa gelmesini sağlayabilir miyiz?
 
Kod: 
Sub Aktar_Topla()
Range("E2:G65536").ClearContents
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Cells(j, "g") = WorksheetFunction.VLookup(Cells(j, "e"), Range("A:C"), 3, 0)
Next
End Sub

İstediğiniz bu mu?

.
 
2. sorunuzu yeni anladım,

Kod: 
Sub Aktar_Topla()
Range("E[COLOR=red]1[/COLOR]:G65536").ClearContents
[COLOR=red][F1] = [B1][/COLOR]
[COLOR=red][G1] = [C1][/COLOR]
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Cells(j, "g") = WorksheetFunction.VLookup(Cells(j, "e"), Range("A:C"), 3, 0)
Next
End Sub

.
 
Değerli Ömer uzmanım. Sizlere ne kadar saygı duysak , ne kadar teşekkür etsek azdır.
İstediğim tam olarak buydu. :)

Eğer kızmazsanız bir şey daha sormak istiyorum. Eğer fiyat kısmında aynı olan ürünlerin fiyatları farklı olursa ortalaması alınabilir mi makro ile ?

30 saniye içinde örnek dosya göndereceğim.

Eğer uğraştıracak bir şey ise hiç sormadım varsayın :)

Uzmanım düşündüm de çok saçma olur bu . Çünkü adetlerin farklı olması durumunda ürünün ortalama fiyatının alınması hiç bir şey ifade etmez. Bu doğru bir hesap olmaz. Doğru yapılabilmesi için , ya orjinal haliyle hesap yapılacak (ki doğrusu da bu olur)
ya da adetlerin miktarı na göre ortalama fiyat çıkartılacak.

Örnek A ürünü 10 adet birim fiyat 2 TL
A ürünü 40 adet birim fiyat 1 TL

Bu ürünün ortalama fiyatı 1,2 TL olur. ki bu da makroyla hesaplaması herhalde çok zor bir şey olur.

Oysa benim sorum şöyle idi ; aynı adetleri toplar gibi fiyatları toplayıp sonra bölmek gibi bir şey .... Yani A ürünün fiyatı 2 TL + 1 TL = 3 TL , ortalaması ise 3/2 = 1,5 TL olur.

1,5 TL yanlış bir fiyat olur. Doğrusu 1,2 TL olmalıdır.

Makro ile de herhalde bu çok zor olur.



Tamam Ömer uzmanım. Sonraki makronuz ile problemim sayenizde çözülmüştür. Teşekkür ederim.

:) :) :)
 
Merhaba,

Bu şekilde kullanabilirsiniz. Yalnız bu gibi tablolarda özet tablo kullanmak en mantıklısı olur.

Kod: 
Sub Aktar()
Range("E1:G65536").ClearContents
[F1] = [B1]
[G1] = [C1]
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Topla = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("C:C"))
Say = WorksheetFunction.CountIf(Range("A:A"), Cells(j, "e"))
Cells(j, "g") = Topla / Say
Next
End Sub

.
 
Örnekteki ortalama fiyat kısmını 1,5 değil de 1,2 olarak hesaplatma imkanı var mıdır Ömer uzmanım?
 

Ekli dosyalar

Kod: 
Sub Aktar()
Application.ScreenUpdating = False
Range("E1:G65536").ClearContents
[F1] = [B1]
[G1] = [C1]
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Topla = Evaluate("=SumProduct((A2:A5000=" & Cells(j, "e").Address & ")*(B2:B5000*C2:C5000))")
Cells(j, "g") = Topla / Cells(j, "f")
Next
Application.ScreenUpdating = True
End Sub

Denermisiniz..

.
 
Söyleyecek takdir kelimesi bulamıyorum.

:) :) :) :)
 
İnanılmaz bir makro yazdınız Ömer uzmanım. Eksiksiz ve tam hesaplama yapıyor. :D

Yani yukarıda "makro ile yapılamaz herhalde ya da çok zordur" dediğim şeyi yaptınız :)
 
İşinize yaradığına sevindim, iyi çalışmalar..

.
 
Kod: 
Sub Aktar_Topla()
Application.ScreenUpdating = False
Range("E1:G65536").ClearContents
[F1] = [B1]
[G1] = [C1]
i = [A65536].End(3).Row
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("E1"), Unique:=True
For j = 2 To [E65536].End(3).Row
Cells(j, "f") = WorksheetFunction.SumIf(Range("A:A"), Cells(j, "e"), Range("B:B"))
Topla = Evaluate("=SumProduct((A2:A5000=" & Cells(j, "e").Address & ")*(B2:B5000*C2:C5000))")
Cells(j, "g") = Topla / Cells(j, "f")
Next
Application.ScreenUpdating = True
End Sub



Ömer uzmanım çok severek kullandığım yukarıdaki kodlarda bugün (21.10.2011) itibariyle bir küçük hatayı farkettim. 414. satırdan sonra hata veriyor. (Fiyat kısımlarını hesaplamıyor) Hemen örnek dosya göndereceğim. Saygılar
 
Örnek dosyada olduğu gibi, düğmeye basınca, G sütununda, 414 üncü satır dahil aşşağıya kadar komple hatalı. Kodda galiba küçük bir düzeltme yapmak gerekecek.
 
Ekteki Örnek dosyadır..
 

Ekli dosyalar

izcik' Alıntı:
Örnek dosyada olduğu gibi, düğmeye basınca, G sütununda, 414 üncü satır dahil aşşağıya kadar komple hatalı. Kodda galiba küçük bir düzeltme yapmak gerekecek.
Genişletmek için tıkla ...

Merhaba,

Kodlardaki 5000 olan aralığı 8000 yaparsanız sorun kalmaz.

Yalnız eski kodları değil de aşağıdaki kodları kullanmanızı tavsiye ederim. Eskisine göre çok daha hızlıdır.

Kod: 
Sub OzetRapor()
 
    Dim d, s, a1, a2, deg, i As Integer, Tutar As Double
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
 
    Range("E:G").ClearContents
    Range("A1:B1").Copy Range("E1"): Range("G1") = Range("C1")
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            Tutar = Cells(i, "B") * Cells(i, "C")
            s = Array(1, Cells(i, "B"), Tutar)
            d.Add deg, s
        Else
            s = d.Item(deg)
            Tutar = Cells(i, "B") * Cells(i, "C")
            s(0) = s(0) + 1
            s(1) = s(1) + Cells(i, "B")
            s(2) = s(2) + Tutar
            d.Item(deg) = s
        End If
    Next i
 
    a1 = d.keys: a2 = d.items
 
    For i = 0 To d.Count - 1
        Cells(i + 2, "E") = a1(i)
        s = a2(i)
        Cells(i + 2, "F") = s(1)
        Cells(i + 2, "G") = s(2) / s(1)
    Next i
 
    Application.ScreenUpdating = True
 
End Sub


.
 
Çok teşekkür ederim uzmanım hemen deniyorum.

Denedim çok hızlı Ömer uzmanım.
 
Son düzenleme:
Ömer uzmanım, aradan 4 sene geçmiş. Verdiğiniz kodları neredeyse her iş günü kullanıyorum. Tekrar sizi anmak istedim :)
Saygılar
 
Rica ederim. Yardımcı olabildiysem ne mutlu.
Saygı ve sevgilerimle.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst