Cazevedo,

Boa tarde!

Veja se é assim.

Oi Wagner, é praticamente isso , só que a minha lista é bem maior, e caso eu coloque os itens novos a macro não retorna os valores para eles. Inseri Basquete e Natação e ele não pegou. Essa macro teria que ser meio que "universal", para qualquer evento novo, ela conseguiria funcionar.

Além disso, esqueci de falar que também preciso que ela me mostre o bairro. Por exemplo, se academia tem em 2 lugares, ela separa os 2 em duas linhas.

Alterei sua planilha colocando ela mais completinha, colunas A a C, meu dados originais, e colunas E a G a saída que preciso.

Muito obrigado.

Abs

Wag ou demais amigos, poderiam me ajudar com esse problema reportado acima. Ainda não consegui solucionar.

Agradeço desde já.

Abs

Veja se ajuda.

Sub ReduzTextoAdicionaValores()
 Dim k As Long, c As Long, x As Long, m As Long
 Dim v As Long, y As Long, w As Long
  Range("E2:G" & Cells(Rows.Count, 5).End(4).Row) = ""
  For k = 2 To Cells(Rows.Count, 1).End(3).Row
   On Error Resume Next
   x = InStr(Cells(k, 1), "MAT")
   y = InStr(Cells(k, 1), "TARD")
   On Error GoTo 0
   w = Application.Max(x, y)
   If w > 0 Then
    Do While Left(Cells(k, 1), w - 1) = _
     Left(Cells(k + c + 1, 1), w - 1) And _
      Cells(k + c + 1, 2) = Cells(k, 2)
      v = Cells(k, 3)
      v = v + Cells(k + c + 1, 3): c = c + 1: k = k + 1
    Loop
    Cells(m + 2, 5) = Left(Cells(k, 1), w - 1)
    Cells(m + 2, 6) = Cells(k, 2)
    If v = 0 Then Cells(m + 2, 7) = Cells(k, 3) Else Cells(m + 2, 7) = v
   Else
    Cells(m + 2, 5) = Cells(k, 1)
    Cells(m + 2, 6) = Cells(k, 2)
    Cells(m + 2, 7) = Cells(k, 3)
   End If
   m = m + 1: c = 0: v = 0
  Next k
End Sub

resultado
ACADEMIA...........BARRA.....150
ACADEMIA...........CENTRO...425
FUTEBOL CAMPO...BARRA.....260
ACADEMIA...........BARRA.....100
BASQUETE...........CENTRO....50
NATAÇÃO............BARRA......50

Osvaldo, quaseeeee isso. Apenas uma diferença, a atividade e o bairro se forem iguais devem ficar na mesma linha, independente se tem "MAT" ou "TARD".....então a primeira linha deveria ficar ACADEMIA.......BARRA......250.
Só esse ajuste já resolve.

Obrigado.

Apenas uma diferença, a atividade e o bairro se forem iguais devem ficar na mesma linha, independente se tem "MAT" ou "TARD".....

Experimente este no lugar do anterior.

Sub ReduzTextoAdicionaValoresV2()
 Dim c As Range, k As Long, x As Long, y As Long, w As Long
 Dim m As Long, v As Long, LR As Long, fA As String
 LR = Cells(Rows.Count, 1).End(3).Row
 Range("E2:G" & Range("E2").End(4).Row) = ""
 Range("A2:A" & LR).Interior.Color = xlNone
 Application.ScreenUpdating = False
 For k = 2 To LR
  If Cells(k, 1).Interior.ColorIndex <> 40 Then
  Cells(k, 1).Interior.ColorIndex = 40
  x = InStr(Cells(k, 1), "MAT"): y = InStr(Cells(k, 1), "TARD")
  w = Application.Max(x, y)
  If w > 0 Then
    Set c = Range(Cells(k, 1), Cells(LR, 1)).Find(Left(Cells(k, 1), w - 1), _
     Lookat:=xlPart)
    If Not c Is Nothing Then
     fA = c.Address
      Do
       If Cells(k, 2) = Cells(c.Row, 2) Then
        v = v + Cells(c.Row, 3)
        Cells(c.Row, 1).Interior.ColorIndex = 40
       End If
        Set c = Range(Cells(k, 1), Cells(LR, 1)).FindNext(after:=c)
      Loop While Not c Is Nothing And c.Address <> fA
      Cells(m + 2, 5) = Left(Cells(c.Row, 1), w - 1)
      Cells(m + 2, 6) = Cells(k, 2): Cells(m + 2, 7) = v
      m = m + 1: v = 0
    End If
  End If
  End If
 Next k
Range("A2:A" & LR).Interior.Color = xlNone
Application.ScreenUpdating = True
End Sub

(again...)
Solução sem VBA, basta apertar Atualizar.