Birleştirilmiş hücrenin başlangıç ve bitiş satır numaraları

tamer42 · Dün 14:23 da

Merhabalar,
Ekli dosyada Sayfa1 "B" sütununda Birleştirilmiş hücrelerden oluşan tabloda;

birleştirilmiş hücrelerin başlangıç ve bitiş satır numaralarını almak istiyorum,

Özetle Sayfa2 deki gibi bir sonuç tablosu oluşturmak istiyorum;

Bu işlemi makro ile nasıl yapabiliriz?

desteğiniz için şimdiden teşekkürler,
iyi Çalışmalar.

Necdet · Dün 21:47 da

Merhaba,
MergeArea ile denedim sonuca ulaşamadım, fazla uğraşmadım.
Klasik yöntemle sonuca ulaştım.
Sayfa1 deki gibi bir sonuç hazırlar.
Sayfa2 deki gibi listeyi siz oluşturabilirsiniz.

Kod:

Public Sub nec()

Dim i   As Long
Dim a1  As Long
Dim a2  As Long
Dim adr As String

i = 2

Do
    If Range("B" & i).MergeCells Then
        adr = Range("B" & i).MergeArea.Address
        a1 = Range(Split(adr, ":")(0)).Row
        a2 = Range(Split(adr, ":")(1)).Row
        Cells(a1, "C") = a1
        Cells(a1, "D") = a2
        i = a2 + 1
    Else
        i = i + 1
    End If
Loop Until Range("B" & i) = ""

End Sub

Korhan Ayhan · Dün 22:59 da

Alternatif olsun..

C++:

Option Explicit

Sub Merge_Cells_Adress_List()
    Dim S1 As Worksheet, S2 As Worksheet, Rng As Range, No As Long
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    S2.Range("B2:D" & S2.Rows.Count).ClearContents
   
    ReDim My_List(1 To S2.Rows.Count, 1 To 3)
   
    For Each Rng In S1.Range("B:B").SpecialCells(xlCellTypeConstants)
        If Rng.MergeCells = True Then
            If Rng.Address = Rng.MergeArea.Cells(1, 1).Address Then
                No = No + 1
                My_List(No, 1) = Rng.Value
                My_List(No, 2) = Evaluate("MIN(ROW(" & Rng.MergeArea.Address & "))")
                My_List(No, 3) = Evaluate("MAX(ROW(" & Rng.MergeArea.Address & "))")
            End If
        End If
    Next

    S2.Range("B2").Resize(No, UBound(My_List, 2)) = My_List
   
    MsgBox "Birleştirilmiş hücrelere ait ilk-son satır bilgileri listelenmiştir."
End Sub

Bu da olabilir...

C++:

Option Explicit

Sub Merge_Cells_Adress_List()
    Dim S1 As Worksheet, S2 As Worksheet, Rng As Range, No As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    S2.Range("B2:D" & S2.Rows.Count).ClearContents
    
    ReDim My_List(1 To S2.Rows.Count, 1 To 3)
    
    For Each Rng In S1.Range("B:B").SpecialCells(xlCellTypeConstants)
        If Rng.MergeCells = True Then
            If Rng.Address = Rng.MergeArea.Cells(1, 1).Address Then
                No = No + 1
                My_List(No, 1) = Rng.Value
                My_List(No, 2) = Rng.MergeArea.Row
                My_List(No, 3) = Rng.MergeArea.Row + Rng.MergeArea.Rows.Count - 1
            End If
        End If
    Next

    S2.Range("B2").Resize(No, UBound(My_List, 2)) = My_List
    
    MsgBox "Birleştirilmiş hücrelere ait ilk-son satır bilgileri listelenmiştir."
End Sub

tamer42 · Dün 23:26 da

Korhan Ayhan' Alıntı:

Alternatif olsun..

C++:

Option Explicit

Sub Merge_Cells_Adress_List()
    Dim S1 As Worksheet, S2 As Worksheet, Rng As Range, No As Long
  
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    S2.Range("B2:D" & S2.Rows.Count).ClearContents
  
    ReDim My_List(1 To S2.Rows.Count, 1 To 3)
  
    For Each Rng In S1.Range("B:B").SpecialCells(xlCellTypeConstants)
        If Rng.MergeCells = True Then
            If Rng.Address = Rng.MergeArea.Cells(1, 1).Address Then
                No = No + 1
                My_List(No, 1) = Rng.Value
                My_List(No, 2) = Evaluate("MIN(ROW(" & Rng.MergeArea.Address & "))")
                My_List(No, 3) = Evaluate("MAX(ROW(" & Rng.MergeArea.Address & "))")
            End If
        End If
    Next

    S2.Range("B2").Resize(No, UBound(My_List, 2)) = My_List
  
    MsgBox "Birleştirilmiş hücrelere ait ilk-son satır bilgileri listelenmiştir."
End Sub

Bu da olabilir...

C++:

Option Explicit

Sub Merge_Cells_Adress_List()
    Dim S1 As Worksheet, S2 As Worksheet, Rng As Range, No As Long
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    S2.Range("B2:D" & S2.Rows.Count).ClearContents
   
    ReDim My_List(1 To S2.Rows.Count, 1 To 3)
   
    For Each Rng In S1.Range("B:B").SpecialCells(xlCellTypeConstants)
        If Rng.MergeCells = True Then
            If Rng.Address = Rng.MergeArea.Cells(1, 1).Address Then
                No = No + 1
                My_List(No, 1) = Rng.Value
                My_List(No, 2) = Rng.MergeArea.Row
                My_List(No, 3) = Rng.MergeArea.Row + Rng.MergeArea.Rows.Count - 1
            End If
        End If
    Next

    S2.Range("B2").Resize(No, UBound(My_List, 2)) = My_List
   
    MsgBox "Birleştirilmiş hücrelere ait ilk-son satır bilgileri listelenmiştir."
End Sub

Korhan Hocam çok teşekkürler,
emeğinize sağlık!!
iyi akşamlar

Necdet · Bugün 10:53

Aklımdan geçeni yaptım.
Alternatif olsun.
Her iki sayfaya sonuçları yazdırır.

Kod:

Sub Deneme()

Dim i As Long
Dim j As Long
Dim rng As Range
Dim bsR As Long
Dim btR As Long

i = 2
j = 1
Application.ScreenUpdating = False

Sayfa2.Range("B1").CurrentRegion.Offset(1).ClearContents
Do
    If Sayfa1.Cells(i, "B").MergeCells Then
        Set rng = Sayfa1.Cells(i, "N").MergeArea
        bsR = rng.Row
        btR = rng.Row + rng.Rows.Count - 1
        Sayfa1.Cells(i, "C") = bsR
        Sayfa1.Cells(i, "D") = btR
        j = j + 1
        Sayfa2.Cells(j, "B") = Sayfa1.Cells(i, "B")
        Sayfa2.Cells(j, "C") = bsR
        Sayfa2.Cells(j, "D") = btR
        i = btR + 1
    Else
        i = i + 1
    End If
Loop Until Cells(i, "B") = ""

Application.ScreenUpdating = True

End Sub

tamer42 · Bugün 11:28

Necdet' Alıntı:

Aklımdan geçeni yaptım.
Alternatif olsun.
Her iki sayfaya sonuçları yazdırır.

Kod:

Sub Deneme()

Dim i As Long
Dim j As Long
Dim rng As Range
Dim bsR As Long
Dim btR As Long

i = 2
j = 1
Application.ScreenUpdating = False

Sayfa2.Range("B1").CurrentRegion.Offset(1).ClearContents
Do
    If Sayfa1.Cells(i, "B").MergeCells Then
        Set rng = Sayfa1.Cells(i, "N").MergeArea
        bsR = rng.Row
        btR = rng.Row + rng.Rows.Count - 1
        Sayfa1.Cells(i, "C") = bsR
        Sayfa1.Cells(i, "D") = btR
        j = j + 1
        Sayfa2.Cells(j, "B") = Sayfa1.Cells(i, "B")
        Sayfa2.Cells(j, "C") = bsR
        Sayfa2.Cells(j, "D") = btR
        i = btR + 1
    Else
        i = i + 1
    End If
Loop Until Cells(i, "B") = ""

Application.ScreenUpdating = True

End Sub

Çok teşekkür ederin Necdet Hocam
iyi Çalışmalar.

Birleştirilmiş hücrenin başlangıç ve bitiş satır numaraları

tamer42

Destek Ekibi

Ekli dosyalar

Necdet

Moderatör

Korhan Ayhan

Administrator

tamer42

Destek Ekibi

Necdet

Moderatör

tamer42

Destek Ekibi