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

[RBozkurt]

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.

 

[Ömer]

Merhaba,

Deneyiniz.

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]

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.