Combinar Celdas en relación a otra celda

Prueba la siguiente macro. Tus datos en la Hoja1, los resultados en la Hoja2.

Sub Combinar_Celdas()
'Por Dante Amor
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim are As Range
  '
  Application.ScreenUpdating = False
  '
  Set sh1 = Sheets("Hoja1")
  Set sh2 = Sheets("Hoja2")
  lr = sh1.Range("A:L").Find("*", , xlValues, , xlByRows, xlPrevious).Row
  ReDim b(1 To lr, 1 To Columns("L").Column)
  For Each are In sh1.Range("A2", sh1.Range("A" & lr)).SpecialCells(xlCellTypeConstants).Areas
    j = are.Cells(1).Row
    For m = j To lr
      If sh1.Range("B" & m).Value = "" And sh1.Range("J" & m).Value = "" Then Exit For
      For k = 1 To UBound(b, 2)
        Select Case k
          Case 1, 2, 8, 9, 10, 11
            If b(j, k) = "" Then
              b(j, k) = sh1.Cells(m, k)
            Else
              b(j, k) = b(j, k) & vbLf & sh1.Cells(m, k)
            End If
          Case 5
            b(m, k) = sh1.Cells(m, k)
          Case Else
            If sh1.Cells(m, k) <> "" Then b(j, k) = sh1.Cells(m, k)
        End Select
      Next
    Next
  Next
  Sh2. Cells. ClearContents
  Sh2. Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

buenas tardes...... corre la macro que me ha enviado ... pero no combina las celdas solo se queda con los datos de la primer celda y no combina o retiene los datos de las otras celdas..... usted me ayudo con este codigo :

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("C").UnMerge
ini = 2
cad = Cells(2, "C") & " "
u = Range("C" & Rows.Count).End(xlUp).Row
Range("B" & u + 1) = "Fin"
For i = 4 To u + 1
If Cells(i, "B") <> "" Then
With Range(Cells(ini, "C"), Cells(i - 1, "C"))
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.MergeCells = True
End With
Cells(ini, "C") = cad
ini = i
cad = ""
End If
cad = cad & Cells(i, "C") & " "
Next
Range("B" & u + 1) = ""
Application.ScreenUpdating = True
Range("C:C").UnMerge
MsgBox "Fin"
End Sub

este macro funciona solo que es para una sola columna ....el mismo procedimiento quiero hacer pero para varias columnas..... podría duplicar........solo que el código se hace muy largo y quiero que la combinación se haga en la misma hoja1...........

Otro dato que me olvide es que los datos de color rojo de la  columna "E" se se pueda copiar en otra columna insertada........ 

y pueda quedar de esta forma....:

En la segunda imagen no veo los datos combinados.

Puedes enviarme tu archivo con 2 hojas.

En la hoja1 poner los datos originales.

En la hoja2 pon el resultado que quieres.

https://docs.google.com/spreadsheets/d/1FOTLK7RjbgOoZiCGXkiOlxyqXnpsbxuM/edit?usp=sharing&ouid=109258364453015021448&rtpof=true&sd=true 

Te envié una solicitud para poder descargar el archivo.

archivo

Sigue sin compartir el archivo, no lo puedo descargar. Te envié la solicitud.

Ya tengo el archivo. Lo reviso

Prueba la siguiente.

Tus datos en la hoja1, los resultados en la hoja2

Option Explicit
Sub Combinar_Celdas()
'Por Dante Amor
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim a As Variant, b As Variant, c As Variant
  Dim cad As String
  '
  Set sh1 = Sheets("Hoja1")
  Set sh2 = Sheets("Hoja2")
  '
  lr = sh1.Range("A:O").Find("*", , xlValues, , xlByRows, xlPrevious).Row
  a = sh1.Range("A2:O" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1) + 1, 1 To UBound(a, 2) + 1)
  ReDim c(1 To UBound(a, 1) + 1, 1 To UBound(a, 2) + 1)
  '
  For i = 1 To UBound(a, 1) - 1
    cad = ""
    For k = 1 To UBound(a, 2)
      cad = cad & a(i, k)
    Next
    '
    If Left(a(i, 1), 4) <> "TOTA" And cad <> "" Then
      j = j + 1
      m = 0
      For k = 1 To UBound(a, 2)
        m = m + 1
        If k = 6 Then m = m + 1
        b(j, m) = a(i, k)
      Next
    End If
  Next
  '
  m = 0
  For i = 1 To UBound(b, 1) - 1
    If Len(b(i, 1)) = 8 Then
      m = m + 1
      For j = i To UBound(b, 1) - 1
        If Len(b(j + 1, 1)) = 8 Then Exit For
        For k = 1 To UBound(b, 2)
          Select Case k
            Case 1, 2, 12, 13, 14, 15
              If b(j, k) <> "" Then
                If c(m, k) = "" Then
                  c(m, k) = b(j, k)
                Else
                  c(m, k) = c(m, k) & " " & vbLf & b(j, k)
                End If
              End If
            Case 5
              c(m, k) = b(i, k)
              c(m, k + 1) = b(i + 1, k)
            Case 6
            Case Else
              c(m, k) = b(i, k)
          End Select
        Next
      Next
    End If
  Next
  '
  Application.ScreenUpdating = False
  With Sheets("Hoja2")
    sh1.Rows(1).Copy .Range("A1")
    .Range("G1").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightOrBelow
    .Rows("2:" & Rows.Count).ClearContents
    .Range("A2").Resize(UBound(c, 1), UBound(b, 2)).Value = c
    .Cells.WrapText = False
  End With
End Sub