• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Buton yardımı ile hücre birleştirme ve ayırma

  • Konbuyu başlatan Konbuyu başlatan ongbey
  • Başlangıç tarihi Başlangıç tarihi
O

ongbey

Katılım
29 Aralık 2004
Mesajlar
82
Merhabalar,
Ekte örneği olan şekilde, bir butona basmak suretiyle hücreleri birleştirmek ve ayırmak istiyorum. Burada önemli olan işlemin tersine döndürülebilir olmasıdır.
İlgilenen arkadaşlar için şimdiden teşekkürler.
 

Ekli dosyalar

Bu şekilde deneyebilirsiniz.
Kod: 
Sub aveb()
If ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır" Then
[H4:H7,H8:H11,H12:H15].UnMerge
ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Birleştir"
Else
ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Birleştir"
[H4:H7,H8:H11,H12:H15].Merge
ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır"
End If
End Sub
 

Ekli dosyalar

Son düzenleme:
Hocam teşekkürler, fakat hücreler ayrıldığında Durum1' e dönüş olmuyor. Benim amacım hücreler ayrıldığında tüm hücrelerin aynı sayı ile dolması. Yani Durum1'den Durum2' ye, sonra Durum2' den Durum1' geçiş tam olarak gerçekleşsin. Ayrıca, ben kısa olarak yazdım ama aynı kolondaki tüm hücrelerde aynı olayın gerçekleşmesini istiyorum.
 
Kod: 
Sub birlestir()
    Application.DisplayAlerts = False
    bas = 4
    For i = 4 To Cells(Rows.Count, 2).End(3).Row
        If Cells(i, 3).MergeCells Then Exit Sub
        If Cells(i, 3) = Cells(i + 1, 3) Then
            son = i + 1
        Else
            With Range(Cells(bas, 3), Cells(son, 3))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                bas = i + 1
            End With
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

Sub coz()
    With Range("C4:C" & Cells(Rows.Count, 2).End(3).Row)
        .MergeCells = False
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub birlestir()
    Application.DisplayAlerts = False
    bas = 4
    For i = 4 To Cells(Rows.Count, 2).End(3).Row
        If Cells(i, 3).MergeCells Then Exit Sub
        If Cells(i, 3) = Cells(i + 1, 3) Then
            son = i + 1
        Else
            With Range(Cells(bas, 3), Cells(son, 3))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                bas = i + 1
            End With
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

Sub coz()
    With Range("C4:C" & Cells(Rows.Count, 2).End(3).Row)
        .MergeCells = False
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
End Sub
Genişletmek için tıkla ...

Veyselemre hocam, teşekkürler. İstediğim böyle bir şeydi.
 
ongbey' Alıntı:
Veyselemre hocam, teşekkürler. İstediğim böyle bir şeydi.
Genişletmek için tıkla ...

Hocam bir şey fark ettim. Çöz komutu verince en son sayı olan 37'de hata veriyor. Dosyayı verdiğiniz kod uygulanmış olarak ekte bulabilirsiniz. Sanırım sorun, son hücreyi bulmaktan kaynaklanıyor. Bunun çözümü var mıdır ?
 

Ekli dosyalar

Yukarıdaki dosyada yar alan kodda ufak bir düzeltme yapılması gerekiyor, yardımcı olacak varmı acaba ?
 
Kod: 
Sub birlestir()
        Application.DisplayAlerts = False
        bas = 4
        For i = 4 To Cells(Rows.Count, 3).End(3).Row
            If Cells(i, 3).MergeCells Then Exit Sub
            If Cells(i, 3) = Cells(i + 1, 3) Then
                son = i + 1
            Else
                If son > bas Then
                    With Range(Cells(bas, 3), Cells(son, 3))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        bas = i + 1
                    End With
                End If
            End If
        Next i
        Application.DisplayAlerts = True
End Sub
Sub coz()
        Set sonHuc = Cells(Rows.Count, 3).End(3)
        sonSat = sonHuc.Row
        If sonHuc.MergeCells Then sonSat = sonSat + sonHuc.MergeArea.Rows.Count - 1
        For i = 4 To sonSat - 1
            If Cells(i, 3).MergeCells Then GoTo cozum
        Next i
        Exit Sub
cozum:
        With Range("C4:C" & sonSat)
            .UnMerge
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            .Value = .Value
            .Borders.LineStyle = xlContinuous
        End With
End Sub


Kod: 
Sub birlestirCoz()
    If ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır" Then
        Set sonHuc = Cells(Rows.Count, 3).End(3)
        sonSat = sonHuc.Row
        If sonHuc.MergeCells Then sonSat = sonSat + sonHuc.MergeArea.Rows.Count - 1
        For i = 4 To sonSat - 1
            If Cells(i, 3).MergeCells Then GoTo cozum
        Next i
        Exit Sub
cozum:
        With Range("C4:C" & sonSat)
            .UnMerge
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            .Value = .Value
            .Borders.LineStyle = xlContinuous
        End With
        ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Birleştir"
    Else
        Application.DisplayAlerts = False
        bas = 4
        For i = 4 To Cells(Rows.Count, 3).End(3).Row
            If Cells(i, 3).MergeCells Then Exit Sub
            If Cells(i, 3) = Cells(i + 1, 3) Then
                son = i + 1
            Else
                If son > bas Then
                    With Range(Cells(bas, 3), Cells(son, 3))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        bas = i + 1
                    End With
                End If
            End If
        Next i
        Application.DisplayAlerts = True
        ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır"
    End If
End Sub
 
Son düzenleme:
veyselemre' Alıntı:
Kod: 
Sub birlestir()
        Application.DisplayAlerts = False
        bas = 4
        For i = 4 To Cells(Rows.Count, 3).End(3).Row
            If Cells(i, 3).MergeCells Then Exit Sub
            If Cells(i, 3) = Cells(i + 1, 3) Then
                son = i + 1
            Else
                If son > bas Then
                    With Range(Cells(bas, 3), Cells(son, 3))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        bas = i + 1
                    End With
                End If
            End If
        Next i
        Application.DisplayAlerts = True
End Sub
Sub coz()
        Set sonHuc = Cells(Rows.Count, 3).End(3)
        sonSat = sonHuc.Row
        If sonHuc.MergeCells Then sonSat = sonSat + sonHuc.MergeArea.Rows.Count - 1
        For i = 4 To sonSat - 1
            If Cells(i, 3).MergeCells Then GoTo cozum
        Next i
        Exit Sub
cozum:
        With Range("C4:C" & sonSat)
            .UnMerge
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            .Value = .Value
            .Borders.LineStyle = xlContinuous
        End With
End Sub


Kod: 
Sub birlestirCoz()
    If ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır" Then
        Set sonHuc = Cells(Rows.Count, 3).End(3)
        sonSat = sonHuc.Row
        If sonHuc.MergeCells Then sonSat = sonSat + sonHuc.MergeArea.Rows.Count - 1
        For i = 4 To sonSat - 1
            If Cells(i, 3).MergeCells Then GoTo cozum
        Next i
        Exit Sub
cozum:
        With Range("C4:C" & sonSat)
            .UnMerge
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            .Value = .Value
            .Borders.LineStyle = xlContinuous
        End With
        ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Birleştir"
    Else
        Application.DisplayAlerts = False
        bas = 4
        For i = 4 To Cells(Rows.Count, 3).End(3).Row
            If Cells(i, 3).MergeCells Then Exit Sub
            If Cells(i, 3) = Cells(i + 1, 3) Then
                son = i + 1
            Else
                If son > bas Then
                    With Range(Cells(bas, 3), Cells(son, 3))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        bas = i + 1
                    End With
                End If
            End If
        Next i
        Application.DisplayAlerts = True
        ActiveSheet.Shapes("Düğme 1").TextFrame.Characters.Text = "Ayır"
    End If
End Sub
Genişletmek için tıkla ...

Hocam Çöz komutu gayet güzel çalıştı, fakat bu sefer Birleştir komutu en son rakam olan 37 leri birleştirmiyor. Herhalde ufak bir ayrıntı düzeltilmesi lazım. Sizi de uğraştırıyorum ama ....
 
Yukardaki kodları güncelledim. Bir deneyin
 
Hocam bu sefer dört dörtlük çalışıyor. Zaman ayırdığınız için teşekkür ederim, elinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst