6000 sayfalık verıyı sınıflandırmak

[m_ek_38]

Merhaba

Elimde 6000 bin satırlı bir satış raporu var bunların bir bölümünü ekliyorum, benim isteğim

örneğin C2-C8 'e kadar Avakado olan ürünün tek bir satır halinde ve toplam halinde olması rapor gün gün ayrı ayrı yazıyor fakat buna gerek yok tek toplam şeklinde nasıl yapabilirim.

Önerinizden yola çıkarak tüm dosyaya uygulacağım. Pivot table hali var fakat düzenli bir hale getiremedim

http://s5.dosya.tc/server4/4znmsu/ornek.xlsx.html

acil yardımlarınızı bekliyorum teşekkür ederim

 

[Ziynettin]

Merhaba,

Kodu çalıştırdiğınzda verileriniz sayfa2 de listeleniyor.

Sub Rapor()
Dim s1 As Worksheet, S2 As Worksheet, d As Object
Dim a(), b()
Dim i As Long, Say As Long, x As Byte
Set s1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A1:j" & s1.Range("C" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 3)) Then
            Say = Say + 1
            d(a(i, 3)) = Say
            For x = 1 To 5
                b(Say, x) = a(i, x)
            Next x
        End If
            For x = 6 To 10
                b(d(a(i, 3)), x) = b(d(a(i, 3)), x) + a(i, x)
            Next x
        b(d(a(i, 3)), 9) = a(i, 9)
    Next i

S2.Cells.ClearContents
If Say > 0 Then
    S2.[B2].Resize(Say).NumberFormat = "@"
    S2.[D2].Resize(Say).NumberFormat = "dd.mm.yyyy"
    S2.[E2].Resize(Say).NumberFormat = "@"
    S2.[A1].Resize(Say, UBound(a, 2)) = b
    S2.[F2].Resize(Say, 5).NumberFormat = "#,##0.00"
    S2.[I2].Resize(Say).NumberFormat = "0%"
End If
MsgBox "İşlem tamam....", vbInformation
End Sub

 

[m_ek_38]

verdiğiniz kodlar çok işime yaradı Allah razı olsun sizden fakat orjinal dosyamda hata ile karşılaşıyorum tabiki hata benim A-J'ye kadar sutunlarım mevcut satır sayım da 5896 da bitiyor kodlarda nereyi değiştirmem gerek
"Run-time error '9':
Subscript out of range
" hatası alıyorum

 

[m_ek_38]

Merhaba,

Kodu çalıştırdiğınzda verileriniz sayfa2 de listeleniyor.

Sub Rapor()
Dim s1 As Worksheet, S2 As Worksheet, d As Object
Dim a(), b()
Dim i As Long, Say As Long, x As Byte
Set s1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A1:j" & s1.Range("C" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 3)) Then
            Say = Say + 1
            d(a(i, 3)) = Say
            For x = 1 To 5
                b(Say, x) = a(i, x)
            Next x
        End If
            For x = 6 To 10
                b(d(a(i, 3)), x) = b(d(a(i, 3)), x) + a(i, x)
            Next x
        b(d(a(i, 3)), 9) = a(i, 9)
    Next i

S2.Cells.ClearContents
If Say > 0 Then
    S2.[B2].Resize(Say).NumberFormat = "@"
    S2.[D2].Resize(Say).NumberFormat = "dd.mm.yyyy"
    S2.[E2].Resize(Say).NumberFormat = "@"
    S2.[A1].Resize(Say, UBound(a, 2)) = b
    S2.[F2].Resize(Say, 5).NumberFormat = "#,##0.00"
    S2.[I2].Resize(Say).NumberFormat = "0%"
End If
MsgBox "İşlem tamam....", vbInformation
End Sub

verdiğiniz kodlar çok işime yaradı Allah razı olsun sizden fakat orjinal dosyamda hata ile karşılaşıyorum tabiki hata benim A-J'ye kadar sutunlarım mevcut satır sayım da 5896 da bitiyor kodlarda nereyi değiştirmem gerek
"Run-time error '9':
Subscript out of range
" hatası alıyorum

 

[Ziynettin]

Hatalı dosyayı eklerseniz bakalım.

 

[m_ek_38]

http://www.dosya.tc/server8/c5ztsw/EXAMPLE.xlsx.html

ektedir, parçalayarak formul işe yarıyor fakat tek kalemde çalışması için ne yapmalıyız?

 

[m_ek_38]

Hatalı dosyayı eklerseniz bakalım.

yardımlarınızı bekliyorum

 

[tahsinanarat]

Sn.m_ek_38 6.mesajda eklediğiniz dosyayı çalıştırdım, bende herhangi bir hata mesajı vermedi, bilginiz olsun.

 

[m_ek_38]

Sn.m_ek_38 6.mesajda eklediğiniz dosyayı çalıştırdım, bende herhangi bir hata mesajı vermedi, bilginiz olsun.

en son eklediğim EXAMPLE isimli dosya çalışmıyor , çalıssada belli bir kısmı hesaplıyor son satıra kadar işlem yapmıyor bu yüzden parçalamak zorunda kalıyorum.