Makro kısaltma

[ayagiz44]

Sub Yenı()
'7
For i = 4 To 8
Cells(i + 3, "bk").Formula = Cells(7, i).Formula
Next i
For i = 9 To 13
Cells(i - 2, "bl").Formula = Cells(7, i).Formula
Next i
For i = 14 To 18
Cells(i + -7, "bm").Formula = Cells(7, i).Formula
Next i
For i = 19 To 23
Cells(i + -12, "bn").Formula = Cells(7, i).Formula
Next i
For i = 24 To 28
Cells(i + -17, "bo").Formula = Cells(7, i).Formula
Next i
For i = 29 To 31
Cells(i + -22, "bp").Formula = Cells(7, i).Formula
Next i
For i = 32 To 35
Cells(i + -25, "bq").Formula = Cells(7, i).Formula
Next i
For i = 36 To 36
Cells(i + -29, "br").Formula = Cells(7, i).Formula
Next i
For i = 37 To 41
Cells(i + -30, "bs").Formula = Cells(7, i).Formula
Next i
For i = 42 To 46
Cells(i + -35, "bt").Formula = Cells(7, i).Formula
Next i
For i = 47 To 51
Cells(i + -40, "bu").Formula = Cells(7, i).Formula
Next i
For i = 52 To 56
Cells(i + -45, "bv").Formula = Cells(7, i).Formula
Next i
For i = 57 To 57
Cells(i + -50, "bw").Formula = Cells(7, i).Formula
Next i
For i = 58 To 58
Cells(i + -51, "bx").Formula = Cells(7, i).Formula
Next i

'12
For i = 4 To 8
Cells(i + 8, "bk").Formula = Cells(8, i).Formula
Next i
For i = 9 To 13
Cells(i + 3, "bl").Formula = Cells(8, i).Formula
Next i
For i = 14 To 18
Cells(i - 2, "bm").Formula = Cells(8, i).Formula
Next i
For i = 19 To 23
Cells(i - 7, "bn").Formula = Cells(8, i).Formula
Next i
For i = 24 To 28
Cells(i - 12, "bo").Formula = Cells(8, i).Formula
Next i
For i = 29 To 31
Cells(i - 17, "bp").Formula = Cells(8, i).Formula
Next i
For i = 32 To 35
Cells(i - 20, "bq").Formula = Cells(8, i).Formula
Next i
For i = 36 To 36
Cells(i - 24, "br").Formula = Cells(8, i).Formula
Next i
For i = 37 To 41
Cells(i - 25, "bs").Formula = Cells(8, i).Formula
Next i
For i = 42 To 46
Cells(i - 30, "bt").Formula = Cells(8, i).Formula
Next i
For i = 47 To 51
Cells(i - 35, "bu").Formula = Cells(8, i).Formula
Next i
For i = 52 To 56
Cells(i - 40, "bv").Formula = Cells(8, i).Formula
Next i
For i = 57 To 57
Cells(i - 45, "bw").Formula = Cells(8, i).Formula
Next i
For i = 58 To 58
Cells(i - 46, "bx").Formula = Cells(8, i).Formula
Next i

'17
For i = 4 To 8
Cells(i + 13, "bk").Formula = Cells(9, i).Formula
Next i
For i = 9 To 13
Cells(i + 8, "bl").Formula = Cells(9, i).Formula
Next i
For i = 14 To 18
Cells(i + 3, "bm").Formula = Cells(9, i).Formula
Next i
For i = 19 To 23
Cells(i - 2, "bn").Formula = Cells(9, i).Formula
Next i
For i = 24 To 28
Cells(i - 7, "bo").Formula = Cells(9, i).Formula
Next i
For i = 29 To 31
Cells(i - 12, "bp").Formula = Cells(9, i).Formula
Next i
For i = 32 To 35
Cells(i - 15, "bq").Formula = Cells(9, i).Formula
Next i
For i = 36 To 36
Cells(i - 19, "br").Formula = Cells(9, i).Formula
Next i
For i = 37 To 41
Cells(i - 20, "bs").Formula = Cells(9, i).Formula
Next i
For i = 42 To 46
Cells(i - 25, "bt").Formula = Cells(9, i).Formula
Next i
For i = 47 To 51
Cells(i - 30, "bu").Formula = Cells(9, i).Formula
Next i
For i = 52 To 56
Cells(i - 35, "bv").Formula = Cells(9, i).Formula
Next i
For i = 57 To 57
Cells(i - 40, "bw").Formula = Cells(9, i).Formula
Next i
For i = 58 To 58
Cells(i - 41, "bx").Formula = Cells(9, i).Formula
Next i


Range("BI231").Select

End Sub

Selamlar
Üstadlar yazdığım makroyu çok daha uzun
For i = 58 To 58
Cells(i + 154, "bx").Formula = Cells(48, i).Formula
Next i
son bu şekilde bitiyor nasıl kısaltabilirmiyim selamlar.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub Yeni_Makro()

    Dim i As Long, j As Byte, s As Byte, a As Byte, b As Byte, c As Byte
    Dim x, y, sut As Byte, sat As Long, son As Long
   
    x = Array(5, 1, 1, 1, 4, 2)
    y = Array(5, 3, 4, 1, 5, 1)
   
    sut = 63: sat = 7: son = 212
   
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Range("BK7:BX" & son + 4).ClearContents
   
    For j = 4 To 58
        For i = 7 To son Step 5
            s = 0
            For c = 0 To UBound(x)
                For b = 1 To x(c)
                    For a = 1 To y(c)
                        Cells(i + a - 1, sut + b + s - 1) = Cells(sat, j).Formula
                        j = j + 1
                    Next a
                Next b
                s = s + b - 1
            Next c
            sat = sat + 1: j = 4
        Next i
        If i > son Then MsgBox "İşlem Bitti.": Application.Calculation = xlAutomatic: Exit Sub
    Next j

End Sub

 

[ayagiz44]

Hocam Saygılar Teşekkür ederim.

 

[Ömer]

Önemli değil.

.Formula eklemeyi atlamıştım, kodları güncelledim.
Formüller değilde değerlerin gelmesi yeterliyse .Formula kısmını silersiniz.