Otomatik Olarak Verileri Özetleme

[sulovi]

Herkese merhabalar,

Excel'de bir tablom var ve bu tablonun bir sütununda üretimde kullandığım boylar, ve başka bir sütunda ise o parçadan kaç adet ürettiğim var. Örnekleyecek olursak, aşağıdaki tabloyu baz alabiliriz.

PARÇA ADI​ SİP. ADETİ​ PARÇA BOYU​ A​ 50​ 1152​ B​ 2​ 1231​ C​ 19​ 850​ D​ 6​ 850​ E​ 15​ 1231​ F​ 10​ 1514​ G​ 9​ 265​ H​ 2​ 265​ I​ 2​ 1548​ J​ 6​ 1990​ K​ 16​ 1231​ L​ 19​ 850​ M​ 27​ 1624​

Bu tablodan bir özet çıkarmak istiyorum. Özette kaç farklı boyum varsa hepsini görmek, yanındaki sipariş adediyle beraber her parça için toplam kaç M parça kullanacağımı da görmek istiyorum. Yani görmek istediğim şey şu:

850cm boydan (19+6+19)=44 adet parçaya ihtiyacın var, kullanacağın toplam boy ise 37,400cm.

Tablo çok uzun, dolayısıyla her bir parça boyu için tek tek eğertopla yapamadım. Bunların hepsini otomatik olarak özetleyebileceğim bir yol var mıdır?

 

[dEdE]

Merhaba,
Örnek dosya Linkte

sulovi.xlsm dosyasını indir - download

sulovi.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Sub Test()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
    ss = s1.Cells(Rows.Count, "A").End(3).Row
    myArr = s1.Range("C2:C" & ss)
    Sat = 2
    Say = 0
    s2.Range("A2:C" & ss).ClearContents
   
    Set myList = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
    myList.Sort

For k = 0 To myList.Count - 1
With s1.Range("C:C")
    Set c = .Find(myList(k), , xlValues)
    If Not c Is Nothing Then
        adres = c.Address
        Do
            Say = Say + s1.Cells(c.Row, 2)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adres
    End If
End With
    s2.Cells(Sat, 1) = myList(k)
    s2.Cells(Sat, 2) = Say
    s2.Cells(Sat, 3) = Say * myList(k)
    Sat = Sat + 1
    Say = 0
Next k
End Sub

 

[sulovi]

Merhaba,
Örnek dosya Linkte

sulovi.xlsm dosyasını indir - download

sulovi.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Sub Test()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
    ss = s1.Cells(Rows.Count, "A").End(3).Row
    myArr = s1.Range("C2:C" & ss)
    Sat = 2
    Say = 0
    s2.Range("A2:C" & ss).ClearContents
  
    Set myList = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
    myList.Sort

For k = 0 To myList.Count - 1
With s1.Range("C:C")
    Set c = .Find(myList(k), , xlValues)
    If Not c Is Nothing Then
        adres = c.Address
        Do
            Say = Say + s1.Cells(c.Row, 2)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adres
    End If
End With
    s2.Cells(Sat, 1) = myList(k)
    s2.Cells(Sat, 2) = Say
    s2.Cells(Sat, 3) = Say * myList(k)
    Sat = Sat + 1
    Say = 0
Next k
End Sub

Yanıtınız için teşekkür ederim. Bunu kendi tabloma uyarlarken "Set c" ifadelerindeki c'yi, mevcut tablomdaki ilgili sütun harfi ile değiştirmem gerekiyor mu, yoksa sadece "C:C"'leri mi değiştireceğim?

 

[dEdE]

Merhaba,
"Set" ifadesi bir değişken ataması için kullanılmış olup, sütun adları ile ilişkisi yoktur. Bu ifade de değişiklik yapmamalısınız.
"...yoksa sadece "C:C"'leri mi değiştireceğim? ..." evet bunları kendi tablonuza uyarlayabilirsiniz.

 

[sulovi]

Merhaba,
"Set" ifadesi bir değişken ataması için kullanılmış olup, sütun adları ile ilişkisi yoktur. Bu ifade de değişiklik yapmamalısınız.
"...yoksa sadece "C:C"'leri mi değiştireceğim? ..." evet bunları kendi tablonuza uyarlayabilirsiniz.

Teşekkür ederim. Kodu çalıştırıyorum ancak "Set myList = CreateObject("System.Collections.ArrayList")" satırında "Automation Error" alıyorum. Excel versiyonum ile alakalı olabilir mi?

 

[omemo]

Sitede bu sorunun cevabı vardı. Hata mesajını sitede aramanızı öneririm

 

[maliex]

Merhaba
"Automation Error"uyarısı için "windows özelliklerini aç veya kapat" alanından ".net Framework 3.5 " işaretleyiniz

Sub ozet()
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    S2.Range("A2:C" & S2.Rows.Count).Clear
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:C" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 3)
  
    For X = LBound(Veri) To UBound(Veri)

            Aranan = Veri(X, 3)
            If Not Dizi.Exists(Aranan) Then
                Say = Say + 1
                Dizi.Add Aranan, Say
                Liste(Say, 1) = Veri(X, 3)
                Liste(Say, 2) = Veri(X, 2)
                Liste(Say, 3) = Veri(X, 3) * Veri(X, 2)
            Else
                Liste(Dizi.Item(Aranan), 2) = Liste(Dizi.Item(Aranan), 2) + Veri(X, 2)
                Liste(Dizi.Item(Aranan), 3) = Liste(Dizi.Item(Aranan), 1) * Liste(Dizi.Item(Aranan), 2)
            End If
        
    Next
  
          
        S2.Range("A2").Resize(Say, 3) = Liste
        S2.Range("A2").Resize(Say, 3).Sort S2.Range("A2"), xlAscending
      
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
      
        
    
End Sub