sablon hazırlama

[kakara]

merhaba ustadlar hergun defalarca yaptıgım bır ıs için sizlerin yardımını beklıyorum makro ıle halledebılırsek benım ıcın zaman acısından ınanılmaz faydası olucak ektekı dosyada nasıl bır sablon olmasını gerektıgını yazdım sımdıden ılgınız ıcın tesekkur ederım.

 

[YUSUF44]

Aslında makro kaydet yöntemiyle yapabilirdiniz. Ben de aşağıdaki kodları makro kaydetle elde ettikten sonra sadeleştirme ve biraz düzenleme yaptım. Ancak "sablonun alt kısmında mıktar ve dovızlı tutar kadar olması gerekıyor" kısmını anlamadım:

Sub sablon()
    Application.ScreenUpdating = False
    Columns("I:AF").Delete Shift:=xlToLeft
    Columns("A:A").Copy [D1]
    Columns("C:C").Copy [A1]
    Columns("C:C").Delete Shift:=xlToLeft
    Application.CutCopyMode = False
    son = Cells(Rows.Count, "D").End(3).Row + 1
    Cells(son, "D").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"
    Range("A1:G" & son).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A1:G" & son).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("A1:G" & son).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A1:G" & son).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A1:G" & son).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A1:G" & son).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A1:G" & son).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A1:G" & son).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı", vbInformation
End Sub

 

[YUSUF44]

Şu da daha kısaltılmış hali:

Sub sablon1()
    Application.ScreenUpdating = False
    Columns("I:AF").Delete Shift:=xlToLeft
    Columns("A:A").Copy [D1]
    Columns("C:C").Copy [A1]
    Columns("C:C").Delete Shift:=xlToLeft
    Application.CutCopyMode = False
    son = Cells(Rows.Count, "D").End(3).Row + 1
    Cells(son, "D").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"
    Range("A1:G" & son).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A1:G" & son).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("A1:G" & son).Borders()
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı", vbInformation
End Sub

 

[kakara]

tesekkurler ustad makro kaydetle yapıyorum ama cerceve kısmını ve toplamları malesef alamıyordum (sureklı satır sayısı degısıyor) o yuzden yardım ıstedım sız adetı toplamıssınız ben dovızlı tutar kısmınıda toplatmak ıstıyorum acaba nasıl bır ekleme yapmam gerekıyor

Cells(son, "D").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"

Cells(son, "G").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"

yaptım oldu sanırım

 

[YUSUF44]

Toplama formülü yanlış olmuş, son satıra göre güncellenmesi gerekiyor, sabah düzeltmeye çalışırım.

 

[YUSUF44]

Günaydın. MAkronun son hali:

Sub sablon1()
    Application.ScreenUpdating = False
    Columns("I:AF").Delete Shift:=xlToLeft
    Columns("A:A").Copy [D1]
    Columns("C:C").Copy [A1]
    Columns("C:C").Delete Shift:=xlToLeft
    Application.CutCopyMode = False
    son = Cells(Rows.Count, "D").End(3).Row + 1
    Cells(son, "D").Formula = "=SUM(D2:D" & son - 1 & ")"
    Cells(son, "G").Formula = "=SUM(G2:G" & son - 1 & ")"
    Range("A1:G" & son).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A1:G" & son).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("A1:G" & son).Borders()
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı", vbInformation
End Sub

 

[kakara]

tesekkurler @YUSUF44 ustad bende farketmıstım kendım çözmeye calısıyordum bu arada kodda bır problem yok saolun