Ayı Haftalara Bölerek 4 işlem

[xnanx]

Merhaba,
Yapmam gereken bir işin içinden bir türlü çıkamadım, Örnek Excelimde 2020 Ayların altında bazı değerler var Ocak ayın da 124 var örnek olarak, benim amacım ocak ayında kaç hafta varsa onu rakamı hafta sayısına bölerek karısına getirmek, Bazı haftalar iki kendinden sonraki aya da dahil olabiliyor bu durumda da ilk aya rakamı yazması,

Burada çeşitli malzemelerin aylar bazında toplamları var



Aşağıdaki formata getirmek istiyorum yani her malzemenin 2020 da ka hafta varsa aşağı doğru sıra ile gelmesi Malzemenin ID numarası ile



Şimdide teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Doğru anlamışsam Haftalık sekmesi D2 hücresine aşağıdaki formülü uygulayıp aşağı çekerek çoğaltınız.

=DÜŞEYARA(haftalık!A2;Veri!$A$1:$N$6;KAÇINCI(B2;Veri!$A$1:$N$1;0);0)/EĞERSAY(B:B;B2)

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Haftalik_Liste()
    Dim Ay As Byte, Gun As Integer, Yil As Integer, Say As Long, Zaman As Double
    Dim Tarih As Date, Hafta As Integer, Dizi As Object, Veri As String
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Y As Long
    Dim Hafta_Say As Byte, Veri_Say As Long, Haftalar As Object, Z As Byte
   
    Zaman = Timer
   
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("haftalık")
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set Haftalar = CreateObject("Scripting.Dictionary")
   
    ReDim Liste(1 To S1.Rows.Count, 1 To 4)
   
    S2.Range("A2:D" & S2.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    Yil = 2020
    Say = 1
   
    For X = 2 To Son
        If S1.Cells(X, 1) <> "" Then
            For Ay = 3 To 14
                For Gun = 1 To 31
                    Tarih = DateSerial(Yil, Ay - 2, Gun)
                    If (Ay - 2) = Month(Tarih) Then
                        If S1.Cells(1, Ay) = Format(Tarih, "mmmm") Then
                            Hafta = WorksheetFunction.WeekNum(Tarih)
                            If Not Haftalar.Exists(Hafta) Then
                                Haftalar.Add Hafta, Nothing
                                Veri = S1.Cells(X, 1) & "#" & Format(Tarih, "mmmm") & "#" & Hafta
                                If Not Dizi.Exists(Veri) Then
                                    Hafta_Say = Hafta_Say + 1
                                    Dizi.Add Veri, Hafta
                                End If
                            End If
                        End If
                    Else
                        Tarih = DateSerial(Yil, Ay - 2, 1)
                    End If
                Next
               
                For Y = Say To Say + Hafta_Say - 1
                    Z = Z + 1
                    Liste(Y, 1) = S1.Cells(X, 1)
                    Liste(Y, 2) = Format(Tarih, "mmmm")
                    Liste(Y, 3) = Dizi.Item(S1.Cells(X, 1) & "#" & Format(Tarih, "mmmm") & "#" & Z)
                    Liste(Y, 4) = S1.Cells(X, Ay) / Hafta_Say
                Next
                Say = Say + Hafta_Say
                Hafta_Say = 0
            Next
        End If
        Veri_Say = Veri_Say + Dizi.Count
        Z = 0
        Haftalar.RemoveAll
        Dizi.RemoveAll
    Next
   
    S2.Range("A2:D" & Veri_Say).Value = Liste
    S2.Columns.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[xnanx]

Sayın Korhan Bey,
Ellerinize sağlık tam istediğim gibi çalıştı, fakat yılın son haftası 53. hafta hem 2020 ve 2021 kapsıyor. Aralık ayını haliyle 4 bölme yerine 3 e bölüyor
Bir şeyler yapılabilir mi?

 

[ÖmerBey]

Merhaba,
Bir makro da ben hazırlamıştım,
Deneyiniz...

Sub kod()
Dim V As Worksheet, H As Worksheet
Dim yil As Integer, sat As Integer, a As Integer, b As Integer
Dim say As Byte
Dim t As Date

Set V = Sheets("Veri")
Set H = Sheets("haftalık")

H.Range("A:D").ClearContents
H.Range("A1:D1") = Array("ID", "Ay", "Hafta", "Miktar")
yil = 2020
sat = 2
Dim dz1
ReDim dz(1 To 5, 1 To 1)

a = 1
dz(2, a) = Format(DateSerial(yil, 1, 1), "Mmmm")
dz(3, a) = a
say = 1
For t = DateSerial(yil, 1, 2) To DateSerial(yil, 12, 31)
    If Weekday(t, vbMonday) = 1 Then
        a = a + 1
        ReDim Preserve dz(1 To 5, 1 To a)
        dz(2, a) = Format(DateValue(t), "Mmmm")
        dz(3, a) = a
        If dz(2, a) = dz(2, a - 1) Then
            say = say + 1
        Else
            dz(5, a - 1) = say
            say = 1
        End If
    End If
Next
dz(5, a) = say

For a = 2 To V.Cells(Rows.Count, "A").End(3).Row
    dz1 = Application.Transpose(dz)
    For b = UBound(dz1) To LBound(dz1) Step -1
        If dz1(b, 5) <> "" Then say = dz1(b, 5)
        dz1(b, 1) = V.Cells(a, "A")
        dz1(b, 4) = V.Cells(a, WorksheetFunction.Match(dz1(b, 2), V.Range("1:1"), 0)) / say
    Next
    H.Cells(sat, 1).Resize(UBound(dz1), UBound(dz1, 2) - 1) = dz1
    sat = sat + UBound(dz1)
Next
End Sub