Birleştirilmiş Hücre var ise rakam yazsın

[sirkülasyon]

Değerli Üstadlarım
R6:R295 arasında birleştirilme yapılmış hücre var ise
AA6:AA295 kısmında da aynen birleştirilen hücre kadar yer birleştirsin ve 1 yazsın
İkinci birleştirme var ise yine ikinci birleştirilen yer kadar birleştirsin ve 2 yazsın.
Böyle 295' e kadar rakam vererek devam etsin.
Böyle bir makro konusunda yardımcı olabilir misiniz?
Örnek dosya ekte sunulmuştur.

Teşekkür eder saygılarımı sunarım

 

[Korhan Ayhan]

Deneyiniz.

Sub BİRLEŞTİRİLMİŞ_ALANLARI_KONTROL_ET()
    Dim X As Integer, No As Integer
    Columns("AA:AA").UnMerge
    Columns("AA:AA").ClearContents
    No = 1
    For X = 6 To 295
        If Cells(X, "R").MergeCells = True Then
            With Cells(X, "R").Offset(0, 9).Resize(Cells(X, "R").MergeArea.Count, 1)
                .Merge
                .Value = No
                .Borders.LineStyle = 1
            End With
        End If
        No = No + 1
        X = X - 1 + Cells(X, "R").MergeArea.Count
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Murat OSMA]

Korhan Bey'in müsadesiyle..

Yanlış anlamadıysam yapılmak istenen işleme bu kodlar alternatif olabilir..

[SIZE="2"]Sub Emre()
    Dim i%, a%
    Columns("R:R").Copy Columns("AA:AA")
    Columns("AA:AA").Interior.ColorIndex = 0
    For i = 6 To 295
        If Cells(i, "AA").MergeCells = True Then
            a = a + 1
            Cells(i, "AA").Value = a
            i = i + Range("AA" & i).MergeArea.Count - 1
        End If
    Next i
    a = Empty: i = Empty
End Sub[/SIZE]

 

[sirkülasyon]

Korhan abi
Sıra numarası verirken sadece 1 veriyor. Ardışık olarak devam etmiyor. Bakabilir misin abi

 

[sirkülasyon]

Murat abi
Makro için sağ olasın. Ellerine sağlık Teşekkür ederim

 

[Korhan Ayhan]

Sıra numarası detayı gözümden kaçmış. Kodu revize ettim. Denersiniz.

 

[sirkülasyon]

Korhan abi
Çok çok teşekkür ederim. Hakkını Helal Et. Sağ Olasın