Boa noite!!

Use o GM

Sub Macro1()
'
' Macro1 Macro
' Use o Gravador de Macro!!!
'

application.ScreenUpdating = 0
    Range("B6:H6").Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(R4C,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    Range("B9:H9").Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(R7C,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    Range("B12:H12").Select
    Range(Selection, Selection.end(xlToRight)).Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(R10C,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    Range("B15:H15").Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(#REF!,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    Range("B18:H18").Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(R16C,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    ActiveWindow.SmallScroll Down:=15
    Range("B21:C21").Select
    Selection.FormulaR1C1 = _
        "=IFERROR(INDEX(COMPROMISSOS!R2C2:R9000C2,MATCH(R19C,COMPROMISSOS!R2C6:R9000C6,0)),"""")"
    ActiveWindow.SmallScroll Down:=-21
    With activesheet
        .Range("B6:H6").value = .Range("B6:H6").value
        .Range("B9:H9").value = .Range("B9:H9").value
        .Range("B12:H12").value = .Range("B12:H12").value
        .Range("B15:H15").value = .Range("B15:H15").value
        .Range("B18:H18").value = .Range("B18:H18").value
        .Range("B21:C21").value = .Range("B21:C21").value
    End With
    Range("A1").Select
    application.ScreenUpdating = 1
End Sub

Att

Boa Tarde Alexandre,

O Problema é que pode ter mais de um compromisso no mesmo dia e eu queria concatenar todos na mesma célula. Acredito que tenha que criar uma variável e depois colocar o valor na célula.

Att.

Boat arde!!

Como teste, apenas como teste, insira essa macro em módulo com a guia COMPROMISSOS selecionada, execute a macro, depois rode a Macro1...talvez lhe ajude..vale lembra, que você pode adaptar a rotina proposta!

Sub Concatenar_AleVBA()
Dim r As Long, lr As Long, nr As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n = 1 Then
    'NADA
  ElseIf n > 1 Then
    Range("B" & r) = Join(Application.Transpose(Range("B" & r & ":B" & (r + n) - 1)), Chr(10))
    Range("F" & r).Offset(1).Resize(n - 1).ClearContents
  End If
  r = r + n - 1
Next r
On Error Resume Next
Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Att

Boa tarde!!

Veja uma nova versão em anexo.

Att