sıklık raporu

[Barons]

merhaba
ekteki dosyada databasexx (SQL den veri almakta) dosyamda veriler var ve burada yüzlerce firma var ama ben 1 tanesi üzerinden çalışma yapıp diğer uyarlayacağım çünkü konuyu anlatmam daha kolay olacak.
"veritabanı" sayfasındaki VBA kod basıldığında kod çalışarak önce "databasexx" sayfasındaki veriyi değerler bazında gitmek ve onun bir firma için son sipariş tarihi ve onun yıl kaç günde bir sipariş verilmiş hesap yapılmaktadır.

Neden 2 Ayrı sayfa derseniz, "databasexx" sayfası SQL'den veri alıp kod bu sayfada direk çalıştığında hata veriyor ama kopyala / yapıştır / değerler yapıp başka bir sayfaya aktarıldığında kod sorunsuz çalışmaktadır. (esas sorun bu değil)

sorun: yıllara göre sıklık kaydedilmektedir ancak kod verinin bir kısmını hatalı hesaplamaktadır.(son sipariş tarihi doğru ancak Yıllara göre sıklık rakamı yanlış gelmektedir.)
istek: ikinci olarakda yılın ilk sipariş tarihi yok sayılmalıdır. (ayrıca "ornek" sayfasında nasıl olması gerektiği açıklanmıştır.
umarım karışık anlatmamışımdır.
yardımcı olacak herkese şimdiden teşekkür ederim.

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Sheets("database").Copy after:=Sheets(Sheets.Count)

    Range("f:af").Delete
    Range("b:d").Delete

    Columns("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    Son = Cells(Rows.Count, 1).End(3).Row

    Columns("A:B").Sort Range("b2"), , Range("A2")
    With Range("C2:C" & Son)
        .FormulaR1C1 = "=RC[-2]"
        .Offset(, 1).FormulaR1C1 = "=YEAR(RC[-1])"
        .Offset(, 2).FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],R[-1]C,R[-1]C+1)"
        .Offset(, 3).FormulaR1C1 = "=IF(AND(RC[-4]=R[-1]C[-4],RC[-2]=R[-1]C[-2]),RC[-5]-R[-1]C[-5],"""")"
        .Offset(, 4).Formula = Replace("=IFERROR(AVERAGEIFS($F$2:$F$@,$B$2:$B$@,B2,$D$2:$D$@,D2),0)", "@", Son)
        .Resize(, 5).Value = .Resize(, 5).Value
    End With

    For i = Son To 3 Step -1
        If Cells(i, 2) = Cells(i - 1, 2) Then
            Cells(i - 1, 3) = Cells(i, 3)
            If Cells(i, 4) = Cells(i - 1, 4) Then Rows(i).ClearContents
        End If
    Next i

    Range("a:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Son = Cells(Rows.Count, 1).End(3).Row

    mn = WorksheetFunction.Min(Range("D2:D" & Son).Value)
    mx = WorksheetFunction.Max(Range("D2:D" & Son).Value)
    mxE = WorksheetFunction.Max(Range("E2:E" & Son).Value)

    ReDim lst(0 To mxE, 0 To mx - mn + 2)
    lst(0, 0) = "Firma"
    lst(0, 1) = "Son Sipariş Tarihi"
    For i = mn To mx
        lst(0, sut + 2) = i
        sut = sut + 1
    Next i

    For i = 2 To Son
        Say = Cells(i, 5)
        lst(Say, 0) = Cells(i, 2)
        lst(Say, 1) = Cells(i, 3)
        yilSira = Cells(i, 4) - mn + 2
        lst(Say, yilSira) = Cells(i, 7)
    Next i

    Range("j1").Resize(Say + 1, mx - mn + 3).Value = lst
    Range("A:I").Delete
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[Barons]

Veysel bey çok teşekkürler şu an olmuş gözüküyor..elinize sağlık...daha detaylı inceleyeceğim. orjinal dosya daha büyük 50 bin satır vardır acaba yavaşlama ne düzeyde olacak onu merak ediyorum.
tekrar çok teşekkürler

 

[Barons]

Veysel bey merhaba,
kod'u 15 bin satıra uyguladığımda dakikalarca imleç dönüyor ve escape ile çıkmak zorunda kalıyorum.
yinede yardım ve emeğiniz için çok teşekkür ederim.

 

[veyselemre]

Option Explicit

Sub test()
Dim zaman, son, i, mn, mx, mxE, sut, say, yilSira
    zaman = Timer
    Application.ScreenUpdating = False
    Sheets("Rapor").Select
    Cells.Delete
    Sheets("database").Range("A:A,E:E").Copy Range("A1")

    Columns("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

    son = Cells(Rows.Count, 1).End(3).Row

    Columns("A:B").Sort Range("b2"), , Range("A2")
    With Range("C2:C" & son)
        .FormulaR1C1 = "=RC[-2]"
        .Offset(, 1).FormulaR1C1 = "=YEAR(RC[-1])"
        .Offset(, 2).FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],R[-1]C,R[-1]C+1)"
        .Offset(, 3).FormulaR1C1 = "=IF(AND(RC[-4]=R[-1]C[-4],RC[-2]=R[-1]C[-2]),RC[-5]-R[-1]C[-5],"""")"
        .Offset(, 4).Formula = Replace("=IFERROR(AVERAGEIFS($F$2:$F$@,$B$2:$B$@,B2,$D$2:$D$@,D2),0)", "@", son)
        .Resize(, 5).Value = .Resize(, 5).Value
    End With

    For i = son To 3 Step -1
        If Cells(i, 2) = Cells(i - 1, 2) Then
            Cells(i - 1, 3) = Cells(i, 3)
            If Cells(i, 4) = Cells(i - 1, 4) Then Rows(i).ClearContents
        End If
    Next i

    Range("a:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    son = Cells(Rows.Count, 1).End(3).Row

    mn = WorksheetFunction.Min(Range("D2:D" & son).Value)
    mx = WorksheetFunction.Max(Range("D2:D" & son).Value)
    mxE = WorksheetFunction.Max(Range("E2:E" & son).Value)

    ReDim lst(0 To mxE, 0 To mx - mn + 2)
    lst(0, 0) = "Firma"
    lst(0, 1) = "Son Sipariş Tarihi"
    For i = mn To mx
        lst(0, sut + 2) = i
        sut = sut + 1
    Next i

    For i = 2 To son
        say = Cells(i, 5)
        lst(say, 0) = Cells(i, 2)
        lst(say, 1) = Cells(i, 3)
        yilSira = Cells(i, 4) - mn + 2
        lst(say, yilSira) = Cells(i, 7)
    Next i

    Range("j1").Resize(say + 1, mx - mn + 3).Value = lst
    Range("A:I").Delete
    Columns.AutoFit
       
    Application.ScreenUpdating = True
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - zaman, "0.00") & " Saniye", vbInformation

End Sub

Böyle bir deneyin.
En başından tüm verilerinizi almaktan kaynaklı bir sıkıntı, size gerekli olan veriler sadece benzersiz tarih ve firma isimleri.
Verileri sql den alırken select distinc şeklinde alırsanız veya hareket tablosundan değilde, fatura dosyasından fatura listesini alırsanız 300-500 veride çalışır dosya 15000 kalem de değil.
Bir de database sayfasında benzersiz filtrelemesi yapıp o şeilde denemek gerekir.

 

[Barons]

çok teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

ADO uygulanmıştır.

 

[Korhan Ayhan]

Küçük bir düzenleme yaptım. Son halini denersiniz.

 

[Barons]

Korhan hocam elinize sağlık...çok hızlı bir yapı oluşmuş ve ortalamaların oluştuğu sayfada çok makbule geçti.test yapma gereği kalmadı..bu ince düşünceniz için ayrıca teşekkür ederim.Şu an gayet sağlıklı çalışıyor.Hız muhteşem. çok teşekkürler.

Veysel Hocamada önerdiği fikirler ve yaptığı çalışma için tekrar tesekkürlerimi iletiyorum.

Bu site sadece Excelde bilgi paylaşımı değil ayrıca güzel insanların yönettiği bir gönül bağı sitesidir.Böyle güzellikleri hayatımızda tutmaya çalışmalıyız.

Katılımcıların sorunlarını bedelsiz hayatlarından zaman harcayarak çözmeye çalışan tüm Site Yöneticilerini ve Hocalarımızı Gönülden tebrik ediyorum.
Allah hepsinin hayatlarına bereket,kolaylık ve güzellikler ihsan eylesin.