Makro ile Tekrarlı veri yazdırma

[AhmetK34]

Merhaba,

Elimde özet tablo benzeri aylık bir veri var ve bu veriyi aylar üzerinde tekrarlı olarak yazmadırmam gerekiyor. Ekte örnek dosyayı paylaştım ancak önden bilgi vermem gerekirse, haziran ayında aylık olarak ax1 malzemesinden 160 adet istenmiş, o ayda pazartesinin denk geldiği 4 hafta olduğunda 160/4=40 olarak 03/06/2024 tarihine bu parçanın 40, 10/06/2024 tarihine 40, 17/06/2024 tarihine 40 gibi bölmem gerekiyor. Malzeme sayım çok olduğu için el ile manuel yapmam fazla zamanımı alıyor. Bir kısa yolu bulunur mu?

 

[AhmetK34]

Şu kısma kadar geldim ancak devamında orantılamayı ve istediğim aydan başlatmayı yapamadım.

 

[Korhan Ayhan]

Paylaştığınız dosyada 2024 Şubat ayı için olması gereken çıktıyı paylaşırmısınız.

 

[AhmetK34]

Tabi ki, ekte sizlere paylaştım. Şubat ayında 4kez pazartesi günüyle hafta başladığı için tablodaki miktar/4 olarak çıktı sayfasına işledim.

 

[AhmetK34]

Paylaştığınız dosyada 2024 Şubat ayı için olması gereken çıktıyı paylaşırmısınız.

Korhan Bey, bakabildiniz mi acaba?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Transpose_Data_Transfer()
    Dim S1 As Worksheet, S2 As Worksheet, X As Integer
    Dim X_Date As Date, First_Monday As Date, Y As Byte
    Dim WF As WorksheetFunction, X_Day As Byte
    Dim Rng As Variant, No As Long, Z As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set WF = WorksheetFunction
    
    S2.Range("A2:D" & S2.Rows.Count).ClearContents
    ReDim My_List(1 To S2.Rows.Count, 1 To 4)
    
    For X = 3 To S1.Cells(1, S1.Columns.Count).End(1).Column
        X_Date = DateSerial(Left(S1.Cells(1, X), 4), Right(S1.Cells(1, X), 2), 1)
        X_Day = Int((Weekday(X_Date - 2) + WF.EoMonth(X_Date, 0) - X_Date) / 7)
        First_Monday = IIf(Weekday(X_Date, vbMonday) > 1, X_Date + (8 - Weekday(X_Date, vbMonday)), X_Date)
        
        Rng = S1.Range("A2:B" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
        
        For Y = 1 To X_Day
            For Z = LBound(Rng) To UBound(Rng)
                No = No + 1
                My_List(No, 1) = Rng(Z, 1)
                My_List(No, 2) = Rng(Z, 2)
                My_List(No, 3) = S1.Cells(Z + 1, X) / X_Day
                My_List(No, 4) = First_Monday
            Next
            First_Monday = First_Monday + 7
        Next
    Next

    S2.Range("A2").Resize(No, 4) = My_List
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[AhmetK34]

Koray bey emeğinize sağlık, yalnız şunu eklemek istiyorum ay içerisinde 5 kez pazartesi denk gelen aylar var bunlar için nasıl bi düzenleme yapabilirim?

 

[Korhan Ayhan]

Kod bu durumu kendisi hesaplıyor zaten..

 

[AhmetK34]

Emeğiniz için tekrardan çok teşekkür ederim