Satırları aynı sayfa üzerinde eşit aralıklara bölme

[ciyager]

Merhabalar,

Excel verileri ekteki dosyada olduğu gibi verilmiş olup, aynı sütunda bulunan verileri eşit satır aralıklarına göre bölmeye çalışıyorum ve bu işlemi manuel yapmaya çalışıyorum ve onlarca sayfa var sürem kısıtlı. Yapmaya çalıştığım şey, ocak ayını örnek verirsek eğer 31 günün ilk 10 gününün altına satır oluşturup ortalamasını almak sonra ikinci 10 günün sonra kalan 11 günün aynı sütunda ortalamasını almaya çalışıyorum. bu çalışmayı kod oluşturarak daha kısa sürede bitirmeyi hedefliyorum Yardımcı olursanız sevinirim.
not: bütün işlemler aynı sayfa üzerinde olmalı farklı dosyalara ayırmadan işlem tamamlanmalı.

 

[ciyager]

Lütfen yardımcı olabilir misiniz?

 

[veyselemre]

Sub test()
    Dim son&, hesaplama, i&, ii&, haftason%, bas&
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        hesaplama = .Calculation
        .Calculation = xlCalculationManual
    End With
       
    son = Cells(Rows.Count, 2).End(3).Row
    For i = son To 3 Step -1
        haftason = haftaBul(Int(Cells(i, 6).Value))
        For ii = i - 1 To 2 Step -1
            Cells(ii, 6).Select
            If haftason <> haftaBul(Int(Cells(ii, 6).Value)) Then
           
                bas = ii + 1
                Rows(son + 1).Insert
                With Cells(son + 1, 7)
                    .Formula = "=AVERAGE(G" & bas & ":G" & son & ")"
                    .Borders.Weight = xlMedium
                    .Interior.Color = vbYellow
                End With
                i = ii + 1
                son = ii

                Exit For
               
            End If
        Next ii
    Next i
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = hesaplama
    End With

End Sub

Function haftaBul(gun)
    Select Case gun
        Case Is > 20: haftaBul = 3
        Case Is > 10: haftaBul = 2
        Case Is > 0: haftaBul = 1
        Case Else: haftaBul = 0
    End Select
End Function

 

[ciyager]

Merhaba Veysel Bey, ilginize ve emeğinize çok teşekkür ederim. Veysel Bey, ekteki görsel de belirttiğim gibi işaretlenen hücreler fazla oluyor silmeye çalıştım fakat olmadı. Kodda düzenleme yapılabilir mi ?
Çok teşekkür ederim.

 

[veyselemre]

Muhtemelen kodu birden fazla çalıştırdınız. Kod yalnızca ham sayfada birkez çalıştırılacak şekilde, satır aralarında boşluk olmayacak.

 

[ciyager]

evet hocam öyleymiş. Çok çok teşekkür ederim. Allah sizden ebeden razı olsun.

Veysel Hocam, bir sorunum daha var. eğer ki müsaitseniz ?

 

[ciyager]

Merhabalar,
Ekte belirttiğim dosya ve görselde bulunan verileri düzenlemeye çalışıyorum. Örnek dosyada sayfa 1 de oluşturulan tablo yer almaktadır. Hedeflediğim şey ör: güneşlenme süresi sayfasında bulunan 2000-2021 yıllarında ocak ayına ait ilk on, ikinci on ve üçüncü on değerlerini tabloya taşımak ve yerleştirilen tüm değerler sonrasında tablonun yanında bulunan ortalama başlıklı hücrelere yerleştirmeyi hedefliyorum. Bu konuda kod mu oluşturulabilir yoksa formül yada filtreleme mi yapılabilir? Yardımcı olursanız sevinirim.
Teşekkürler.

 

[ciyager]

Muhtemelen kodu birden fazla çalıştırdınız. Kod yalnızca ham sayfada birkez çalıştırılacak şekilde, satır aralarında boşluk olmayacak.

Veysel Hocam, oluşturulan kodda bulunan değerlerin yanına ilk on,ikinci on veya üçüncü on yazılabilir mi?

 

[veyselemre]

Sub test()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Güneşlenme Süresi")
    Dim w(1 To 2)
    s2.Select
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Cells(Rows.Count, 2).End(3).Row
            If Int(Cells(i, 4).Value) > 1999 Then
                gun = Cells(i, "F").Value
                ay = Cells(i, "E").Value
                yil = Cells(i, "D").Value
                deger = Cells(i, "G").Value
               
                If gun > 20 Then
                    peryot = 3
                ElseIf gun > 10 Then
                    peryot = 2
                Else
                    peryot = 1
                End If
               
                yilAyPeryot = _
                            Format(yil, "0000") & _
                            Format(ay, "00") & _
                            Format(peryot, "00")
                        
                If Not .exists(yilAyPeryot) Then
                    w(1) = 1
                    w(2) = deger
                    .Item(yilAyPeryot) = w
                Else
                    y = .Item(yilAyPeryot)
                    y(1) = y(1) + 1
                    y(2) = y(2) + deger
                    .Item(yilAyPeryot) = y
                End If
            End If
        Next i
       
        s1.Select

        Range("E6:AB41").ClearContents
        For i = 2000 To 2021
            For ii = 1 To 12
                For iii = 1 To 3
                    yilAyPeryot = _
                                Format(i, "0000") & _
                                Format(ii, "00") & _
                                Format(iii, "00")
                    If .exists(yilAyPeryot) Then
                        y = .Item(yilAyPeryot)
                        Cells(ii * 3 + iii + 2, i - 1995).Value = Round(y(2) / y(1), 2)
                    End If
           
                Next iii
            Next ii
        Next i
        For i = 6 To 41
            Range("AA" & i).Formula = "=Average(E" & i & ":Z" & i & ")"
        Next i
    End With

End Sub

 

[ciyager]

Merhabalar,
Oluşturmuş olduğunuz kodu işlediğimde veri aktarımı eksik oluyor. ekteki görselde ortalama kısmında formül oluşuyor ama yıllara ait veri gelmiyor. Verilerin tabloya geleceği şekilde bir kod yazmak mümkün mü? Çözmeye çalıştım ama yapamadım.

 

[veyselemre]

Merhabalar,
Oluşturmuş olduğunuz kodu işlediğimde veri aktarımı eksik oluyor. ekteki görselde ortalama kısmında formül oluşuyor ama yıllara ait veri gelmiyor. Verilerin tabloya geleceği şekilde bir kod yazmak mümkün mü? Çözmeye çalıştım ama yapamadım.

Set s2 = Sheets("Güneşlenme Süresi")

Burdaki sayfa ismini doğru girin.

 

[ciyager]

Hocam denedim olmuyor. Türkçe karakter kullanılmasından ötürü mü sıkıntı oluyor. Denedim o şekilde de olmadı. Diğer sayfalardan istenilen veri gelmiyor.
Şimdi durumu çözdüm galiba. Sarı renkte olan kutucukların yanına ilk ,on ikinci ve üçüncü on şeklinde birşeyler belirleyelim ki veriyi sayfa 1 deki tabloya çekelim. Bu konuda birşeyler yapılabilir mi?