Bu makro aynı işlevi görmesi koşuluyla başka nasıl yazılabilir?

[Tevfik_Kursun]

Günaydın Arkadaşlar,

Sub Birlestir_1()
    Range("Z3:AF14").ClearContents
    For j = 1 To 12
        For i = 5 To [C1] + 4
            If Month(Cells(i, 8)) = j Then
                metin = metin & Cells(i, 2)
            End If
        Next i
        Cells(2 + j, 26) = j
        Cells(2 + j, 27) = metin
            If Cells(2 + j, 27) = "" Then
                Cells(2 + j, 28) = ""
              Else
                Cells(2 + j, 28) = Len(metin) / 4
            End If
            If Cells(2 + j, 27) = "" Then
                Cells(2 + j, 29) = ""
              Else
                If j = 1 Then
                    Cells(2 + j, 29) = 5
                  Else
                    Cells(2 + j, 29) = Cells(1 + j, 30) + 1
                End If
            End If
            If Cells(2 + j, 27) = "" Then
                Cells(2 + j, 30) = ""
              Else
                Cells(2 + j, 30) = Cells(2 + j, 28) + Cells(2 + j, 29) - 1
            End If
            If Cells(2 + j, 27) = "" Then
                Cells(2 + j, 31) = ""
              Else
                Cells(2 + j, 31) = j
            End If
            If Cells(2 + j, 27) = "" Then
                Cells(2 + j, 32) = ""
              Else
                    Cells(2 + j, 32) = "B" & Cells(2 + j, 29) & ":P" & Cells(2 + j, 30)
            End If
        metin = Empty
    Next j
End Sub

Bu makro aynı işlevi görmesi koşuluyla başka nasıl yazılabilir?
Saygılarımla
Ornek

 

[EmrExcel16]

Merhaba , deneyiniz..

Sub EmrTest()
    Range("Z3:AF14").ClearContents
    For i = 5 To Cells(Rows.Count, 8).End(3).Row
        Cells(Month(Cells(i, 8)) + 2, 27) = Cells(Month(Cells(i, 8)) + 2, 27) & Cells(i, 2)
    Next
    For j = 3 To 14
        Cells(j, 26) = j - 2
        If Cells(j, 27) <> "" Then
            Cells(j, 28) = Len(Cells(j, 27)) / 4
            If j = 3 Then Cells(j, 29) = 5
            If j > 3 Then Cells(j, 29) = Cells(j - 1, 30) + 1
            Cells(j, 30) = Cells(j, 28) + Cells(j, 29) - 1: Cells(j, 31) = j - 2
            Cells(j, 32) = "B" & Cells(j, 29) & ":P" & Cells(j, 30)
        End If
    Next
End Sub

 

[Tevfik_Kursun]

Çok teşekkür ederim, arkadaşım.
Saygılarımla

 

[EmrExcel16]

Çok teşekkür ederim, arkadaşım.
Saygılarımla

Rica ederim , sağlıklı günler dilerim..