Makro ile Birleştir&ortalama (Merge&Center) yardımı

[dilek.gumus]

Merhaba benim ekte paylaştığım formatta bir dosyam var Sheet1 de girdiğim datanın satır sayısı kadar sheet2 ye gidip enson kayın altına kaydetmesini istiyorum. ama işlem no ve Kayıt no bilgilerinde eklediğim satır kadar birleştirerek kayıt etmesi mümkün mü? Ekte örnek dosyayı paylaşıyorum. Teşekkürler şimdiden.

 

[veyselemre]

Sub aktar()
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")

    son1 = s1.Cells(Rows.Count, 4).End(3).Row
    son2 = s2.Cells(Rows.Count, 3).End(3).Row + 1

    s1.Range("D5:J" & son1).Copy s2.Cells(son2, 3)
    s1.Range("D1").Copy s2.Cells(son2, 2)
    s1.Range("D2").Copy s2.Cells(son2, 10)

    son22 = s2.Cells(Rows.Count, 3).End(3).Row

    With Range(Cells(son2, "B"), Cells(son22, "B"))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With

    With Range(Cells(son2, "J"), Cells(son22, "J"))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With

    With Range(Cells(son2, "B"), Cells(son22, "J"))
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
    End With

    Set s1 = Nothing
    Set s2 = Nothing
End Sub

 

[dilek.gumus]

Veysel bey teşekkürler, Söyle bir sorun var, aktarım çalışıyor fakat bordür sheet2 de olması gerekirken sheet1 de anlamsız yerde oluşuyor..Eğer yeni bir workbook açıp oraya kayıt yapmasını istersem ne ekleyebilirim?

 

[veyselemre]

Ben sheet2 de deneme yaptığım için sayfa yazmadım, şimdi istediğiniz yerden çalıştırabilirsiniz.

Sub aktar()
    Set s1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    son1 = s1.Cells(Rows.Count, 4).End(3).Row
    SON2 = S2.Cells(Rows.Count, 3).End(3).Row + 1

    s1.Range("D5:J" & son1).Copy S2.Cells(SON2, 3)
    s1.Range("D1").Copy S2.Cells(SON2, 2)
    s1.Range("D2").Copy S2.Cells(SON2, 10)

    SON22 = S2.Cells(Rows.Count, 3).End(3).Row

    With S2.Range("B" & SON2 & ":" & "B" & SON22)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With

    With S2.Range("J" & SON2 & ":" & "J" & SON22)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With

    With S2.Range("B" & SON2 & ":" & "J" & SON22)
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
    End With

    Set s1 = Nothing
    Set S2 = Nothing
End Sub