Çoklu Süzme ve Toplam Alma - Veri Analizi

[efeksk]

Değerli arkadaşlar... Şirkette ihtiyaç üzerine bir veri analizi düzenlemem hasıl oldu.

Konu şöyleki;
Firmalardan gelen malzemeler bir sayfada detaylı olarak kaydediliyor. Bu kayıtlar daha sonra X firması Y firması Z firması gibi aynı firmalar adına işlenmiş verileri önce toplam alarak değerlendiriyor. Örneğin X firmasından 7 kez malzeme gelmiş ve bunların toplamı lazım. Otomatik olarak bu verileri bi makro ve formülü birleştirerek alıyorum. Bu işlemde sıkıntı yok...

Sorun ise X firmasından bugüne kadar 7 kez ayrı ayrı gelen malzemelerin dönemine göre ( Geliş tarihi:01.01.2012 ise dönemi OCAK-2012 yazılıyor). Bu bağlamda: X firmasından OCAK-2012 döneminde, ŞUBAT-2012 döneminde ne kadar malzeme geldi ise bunu sabitlenen hücrelerde toplayarak analiz edecek. Ben bunu biraz uzuuuuuun bi makro kaydı ile başardım. Fakat işlem uzun sürdüğü için acaba daha kısa ve seri bi yolu varmıdır diye düşünmeye başladım. İşte tam bu noktada yardımlarınızı bekliyorum...

 

[Orion1]

Fakat işlem uzun sürdüğü için acaba daha kısa ve seri bi yolu varmıdır diye düşünmeye başladım. İşte tam bu noktada yardımlarınızı bekliyorum...

Merhaba.
Kodlama ile hızlı sonuç alınır.Bir yanlışınız olmasın.
Bakın yolladığım dostada 1 kaç saniyede işi bitiriyor.
Dosyanız ektedir.

Option Base 1
Sub listele_59()
Dim sh1 As Worksheet, sh2 As Worksheet, deg
Dim i As Long, z, n As Long, myarr(), liste(), sat As Long
Set sh1 = Sheets("Sayfa2")
Set sh2 = Sheets("LİSTE")
sh2.Select
Application.ScreenUpdating = False
sh2.Range("B3:R" & sh2.Rows.Count).ClearContents
sat = sh1.Cells(sh1.Rows.Count, "B").End(xlUp).Row
If sat < 30 Then
    Set sh1 = Nothing
    Set sh2 = Nothing
    Exit Sub
End If
liste = sh1.Range("B30:K" & sat).Value
ReDim myarr(1 To 11, 1 To sat)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    deg = UCase(Replace(Replace(liste(i, 1), "i", "İ"), "ı", "I"))
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
        myarr(4, n) = liste(i, 4)
        myarr(5, n) = liste(i, 5)
        myarr(6, n) = liste(i, 6)
        myarr(7, n) = liste(i, 7)
        myarr(8, n) = liste(i, 8)
        myarr(9, n) = liste(i, 9)
        myarr(10, n) = liste(i, 10)
    End If
    myarr(11, z.Item(deg)) = myarr(11, z.Item(deg)) + 1
Next i
Erase liste
Set z = Nothing
ReDim Preserve myarr(1 To 11, 1 To n)
Range("B3").Resize(n, 11) = Application.Transpose(myarr)
Erase myarr
Set sh1 = Nothing
Set sh2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem başarı ile tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[efeksk]

Merhaba.
Kodlama ile hızlı sonuç alınır.Bir yanlışınız olmasın.
Bakın yolladığım dostada 1 kaç saniyede işi bitiriyor.
Dosyanız ektedir.

Option Base 1
Sub listele_59()
Dim sh1 As Worksheet, sh2 As Worksheet, deg
Dim i As Long, z, n As Long, myarr(), liste(), sat As Long
Set sh1 = Sheets("Sayfa2")
Set sh2 = Sheets("LİSTE")
sh2.Select
Application.ScreenUpdating = False
sh2.Range("B3:R" & sh2.Rows.Count).ClearContents
sat = sh1.Cells(sh1.Rows.Count, "B").End(xlUp).Row
If sat < 30 Then
    Set sh1 = Nothing
    Set sh2 = Nothing
    Exit Sub
End If
liste = sh1.Range("B30:K" & sat).Value
ReDim myarr(1 To 11, 1 To sat)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    deg = UCase(Replace(Replace(liste(i, 1), "i", "İ"), "ı", "I"))
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
        myarr(4, n) = liste(i, 4)
        myarr(5, n) = liste(i, 5)
        myarr(6, n) = liste(i, 6)
        myarr(7, n) = liste(i, 7)
        myarr(8, n) = liste(i, 8)
        myarr(9, n) = liste(i, 9)
        myarr(10, n) = liste(i, 10)
    End If
    myarr(11, z.Item(deg)) = myarr(11, z.Item(deg)) + 1
Next i
Erase liste
Set z = Nothing
ReDim Preserve myarr(1 To 11, 1 To n)
Range("B3").Resize(n, 11) = Application.Transpose(myarr)
Erase myarr
Set sh1 = Nothing
Set sh2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem başarı ile tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

Sn. Orion1 öncelikle çok teşekkür ederim ilginize
Lakin benim istediğim. Dosyadaki Sayfa2 Sheets'inin üzerindeki yeşil butonlardan "AYLIK TOPLAMLARI GÜNCELLE" butonu ile ilgiliydi. Acaba bu butonda ki kodlar ile ilgili bir hızlandırma yapılabilir mi onu merak ediyorum ben.

 

[efeksk]

Konu güncel