MAKRO İLE HÜCRE BİRLEŞTİRME VE ORTALAMA

[diablus]

merhabalar. bir listem var. istediğim şey G sütununda yazan sayıya göre H sütununun (H dahil) solundaki tüm sütunlarda yer alan satırların birleşmesi örneğin G1 e 7 yazdığımda A1:A7, B1:B7, C1:C7 vb. şeklinde otomatik birleşmesini, daha sonra G8 e 4 yazdığımda A8:A12, B8:B12 vb. şeklinde ilerlemesi istiyorum. yardımcı olursanız sevinirim.

 

[Muzaffer Ali]

Merhaba.
Sayfanın kod sayfasına aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Variant
    If Not IsNumeric(Target.Value) Then
        MsgBox "Bu alana sadece rakam girişi yapabilirsiniz"
        Exit Sub
    End If
    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        For Each Sutun In Array("A", "B", "C", "D", "E", "F")
            Range(Cells(Target.Row, Sutun), Cells(Target.Row + Target.Value - 1, Sutun)).Merge
        Next
    End If
End Sub

 

[diablus]

Merhaba.
Sayfanın kod sayfasına aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Variant
    If Not IsNumeric(Target.Value) Then
        MsgBox "Bu alana sadece rakam girişi yapabilirsiniz"
        Exit Sub
    End If
    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        For Each Sutun In Array("A", "B", "C", "D", "E", "F")
            Range(Cells(Target.Row, Sutun), Cells(Target.Row + Target.Value - 1, Sutun)).Merge
        Next
    End If
End Sub

hocam çok teşekkürler kod çalıştı çok işime yaradı. ancak şöyle bir sorunum var aynı sayfada kendi kodum vardı ikisini birleştirdiğimde çalışmıyor. sizin yazdığınız kod ile şu kodu nasıl birleştirebilirim.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
For Each Rng In Target.Cells
Rng = WorksheetFunction.Proper(Rng)
Next
End Sub

 

[Muzaffer Ali]

Bunu kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Variant
    Dim Rng As Range
    Application.EnableEvents = False
    For Each Rng In Target.Cells
        Rng = WorksheetFunction.Proper(Rng)
    Next
    Application.EnableEvents = True

    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Bu alana sadece rakam girişi yapabilirsiniz"
            Exit Sub
        End If
        For Each Sutun In Array("A", "B", "C", "D", "E", "F")
            Range(Cells(Target.Row, Sutun), Cells(Target.Row + Target.Value - 1, Sutun)).Merge
        Next
    End If
End Sub

 

[diablus]

Bunu kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Variant
    Dim Rng As Range
    Application.EnableEvents = False
    For Each Rng In Target.Cells
        Rng = WorksheetFunction.Proper(Rng)
    Next
    Application.EnableEvents = True

    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Bu alana sadece rakam girişi yapabilirsiniz"
            Exit Sub
        End If
        For Each Sutun In Array("A", "B", "C", "D", "E", "F")
            Range(Cells(Target.Row, Sutun), Cells(Target.Row + Target.Value - 1, Sutun)).Merge
        Next
    End If
End Sub

teşekkürler ellerinize sağlık