Excel Alt Alta Aynı veri olan hücreleri birleştirme kodu

[nihatra]

Kolay Gelsin
Excel sayfasında alt alta aynı olan verileri birleştir ortalama yapmak için hangi kodu kullanmalıyım. Excel sayfasında binlerce veri olduğu için kod ile yapabilir miyiz.
Teşekkürler

[theLastpart]

Aşağıdaki kodu kullanarak yapabilirsiniz ama yinede oluşturulan güncel raporun doğruluğunu kontrol edin lütfen

Kod: Tümünü seç

Sub MergeCellsAndFormat()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim wb As Workbook
    Dim i As Long
    Dim j As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim subStart As Long
    Dim currentValue As Variant
    Dim subCurrent As Variant
    Dim col As Variant
    Dim colIdx As Integer
    Dim aColIdx As Integer
    Dim sheetName As String
    
    Application.DisplayAlerts = False  ' Hücre birleştirme uyarılarını kapat
    
    Set wb = ThisWorkbook
    Set wsSource = ActiveSheet  ' Aktif sayfayı kullan (veri olan sayfayı seçip makroyu çalıştırın)
    
    ' Veri olup olmadığını kontrol et
    If wsSource.UsedRange.Rows.Count = 1 And wsSource.UsedRange.Columns.Count = 1 Then
        MsgBox "Kaynak sayfada veri bulunamadı. Lütfen veri içeren sayfayı aktif hale getirin."
        Application.DisplayAlerts = True
        Exit Sub
    End If
    
    ' Benzersiz sayfa adı oluştur (tarih-saat-dakika-saniye ile)
    sheetName = "Rapor - " & Format(Now(), "yyyy-mm-dd hh-mm-ss")
    
    ' Yeni sayfa oluştur
    Set wsNew = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    wsNew.Name = sheetName
    
    ' Tüm veriyi yeni sayfaya kopyala (değer ve format ile)
    wsSource.UsedRange.Copy wsNew.Range("A1")
    Application.CutCopyMode = False
    
    aColIdx = wsNew.Columns("A").Column  ' A sütunu indeksi
    
    ' Birleştirecek diğer sütunlar (B, C, D)
    Dim columnsToMerge As Variant
    columnsToMerge = Array("B", "C", "D")
    
    ' A sütununa göre gruplama ve birleştirme (2. satırdan başlayarak)
    i = 2
    Do While i <= wsNew.UsedRange.Rows.Count + wsNew.UsedRange.Row - 1  ' UsedRange son satırı
        startRow = i
        currentValue = wsNew.Cells(i, aColIdx).Value
        If IsEmpty(currentValue) Or currentValue = "" Then
            i = i + 1
            GoTo NextAiteration
        End If
        i = i + 1
        Do While i <= wsNew.UsedRange.Rows.Count + wsNew.UsedRange.Row - 1 And wsNew.Cells(i, aColIdx).Value = currentValue
            i = i + 1
        Loop
        endRow = i - 1
        
        If endRow - startRow + 1 > 1 Then
            ' A sütununda birleştir
            wsNew.Range(wsNew.Cells(startRow, aColIdx), wsNew.Cells(endRow, aColIdx)).Merge
            wsNew.Cells(startRow, aColIdx).VerticalAlignment = xlCenter
            wsNew.Cells(startRow, aColIdx).HorizontalAlignment = xlCenter
            
            ' Bu A grubunda B, C, D sütunlarında alt birleştirmeler yap
            For Each col In columnsToMerge
                colIdx = wsNew.Columns(CStr(col)).Column
                j = startRow
                Do While j <= endRow
                    subStart = j
                    subCurrent = wsNew.Cells(j, colIdx).Value
                    If IsEmpty(subCurrent) Or subCurrent = "" Then
                        j = j + 1
                        GoTo NextSubIteration
                    End If
                    j = j + 1
                    Do While j <= endRow And wsNew.Cells(j, colIdx).Value = subCurrent
                        j = j + 1
                    Loop
                    If j - subStart > 1 Then
                        wsNew.Range(wsNew.Cells(subStart, colIdx), wsNew.Cells(j - 1, colIdx)).Merge
                        wsNew.Cells(subStart, colIdx).VerticalAlignment = xlCenter
                        wsNew.Cells(subStart, colIdx).HorizontalAlignment = xlCenter
                    End If
NextSubIteration:
                Loop
            Next col
        End If
NextAiteration:
    Loop
    
    ' Sütun genişliklerini ayarla
    wsNew.Columns("A").ColumnWidth = 13.57
    wsNew.Columns("B").ColumnWidth = 12.43
    wsNew.Columns("C").ColumnWidth = 8.43
    wsNew.Columns("D").ColumnWidth = 13
    wsNew.Columns("E").ColumnWidth = 10
    wsNew.Columns("F").ColumnWidth = 9
    wsNew.Columns("G").ColumnWidth = 9
    wsNew.Columns("H").AutoFit  ' H sütunu için otomatik
    
    ' Başlık satırı (1. satır) yüksekliğini 75 yap
    wsNew.Rows(1).RowHeight = 75
    
    Application.DisplayAlerts = True  ' Uyarıları tekrar aç
    
    MsgBox "Rapor  '" & sheetName & "'  adı ile oluşturuldu."
End Sub

[nihatra]

Teşekkür ederim. Elinize sağlık Allah Razı Olsun.
Ancak Bu kod çok güzel çalışıyor. Mümkünse Örneğin
E2 hücresindeki rakamı H2 ye
E3 hücresindeki rakamı I2 ye
F2 hücresindeki rakamı j2 ye
F3 hücresindeki rakamı K2 ye gibi kişiye ait olan rakamları yan yana tek satır halinde yapabilir miyiz.
Teşekkürler