Çözüldü Birleşik Hücreyi Referans Alıp Satırları Birleştirme Hakkında

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
686
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Merhabalar

Ekte örnek olarak eklemiş olduğum dosyada 2 adet sayfa vardır.
VERİ sayfasındaki J sütununda bulunan birleşmiş hücreyi referans alarak o aralıkta denk gelen diğer satırları;
manuel olarak hazırladığım SONUÇ sayfasındaki gibi tek satıra indirgeyerek tek bir hücrede aynı şekilde alt alta birleştirilmesi konusunda yardımcı olabilirmisiniz?
Teşekkür ederim.
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Deneyiniz.
Kod:
Sub duzenle()

    Dim S1 As Worksheet, S2 As Worksheet, son As Long, i As Long
    Dim t1 As Long, t2 As Long, t3 As Long, j As Byte, k As Integer, d As String

    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("SONUÇ")
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    S2.Select
    Cells.Clear
 
    son = S1.Cells(Rows.Count, "H").End(xlUp).Row
 
    S1.Range("A1:Z" & son).Copy Range("A1")
    Range("A:I,K:Z").MergeCells = False
 
    For i = 1 To Cells(Rows.Count, "H").End(xlUp).Row
        If Cells(i, "J").MergeCells = True Then
            t1 = i
            t2 = Cells(i, "J").MergeArea.Rows.Count
            i = t1 + t2 - 1
            For j = 1 To 26
                If j <> 10 Then
                    For k = t1 To t1 + t2 - 1
                        If Cells(k, j) <> "" Then
                            d = d & Chr(10) & Cells(k, j)
                        End If
                    Next k
                    With Cells(t1, j).Resize(t2, 1)
                        .Merge
                        d = WorksheetFunction.Substitute(d, Chr(10), "", 1)
                        .Value = d
                        If Len(d) = 0 Then
                            t3 = Cells(t1 - 1, "J").MergeArea.Rows.Count
                            .Value = Cells(t1 - t3, j)
                        End If
                    End With
                    d = ""
                End If
            Next j
        Else
            If Cells(i, "J") <> "" Then
                For j = 1 To 26
                    If j <> 10 Then
                        If Cells(i, j) = "" Then
                            t3 = Cells(i - 1, "J").MergeArea.Rows.Count
                            Cells(i, j) = Cells(i - t3, j)
                          End If
                    End If
                Next j
            End If
        End If
    Next i

    With Cells
        .UnMerge
        .WrapText = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .EntireRow.AutoFit
    End With
 
    On Error Resume Next
    [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
    MsgBox "İşlem bitti.", vbInformation
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
     
End Sub
 

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
686
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Teşekkürler sayın @Ömer üstadım elinize sağlık. Hata gözükmüyor şuan. Biraz test yapayım noksanlık olursa dönüş yaparım.
 
Üst