Adicionar Comentário pelo VBA - JJoão (08/2005)

Dúvida colocada: "..Queria inserir ou modificar comentários em celulas em que o conteudo desses comentários será o conteudo de outra celula.."

Solução: Duas macros
1ª - Inserção de comentário numa celula com o conteudo de outra;
2ª - Outra macro para o mesmo fim, mas com a possibilidade de escolher a(s) célula(s) com o conteúdo a colocar no comentário. Permite seleccionar uma ou mais células e não levará em conta células vazias.
1ª Macro

Sub AdicionarComentario()
    Dim sTexto As String
   'recolhe o texto da celula A1
    sTexto = Range("A1")
   'só avança caso haja conteudo para o comentário
    If Len(sTexto) = 0 Then Exit Sub
   'usar a celula activa
    With ActiveCell
       'evita erros ao eliminar ou adicionar o comentário
        On Error Resume Next
       'eliminar comentário caso exista
        .Comment.Delete
       'Adicionar novo
        .AddComment
       'Estado do comentário
        .Comment.Visible = False
       'Inserir texto
        .Comment.Text Text:=sTexto
  End With
End Sub

2ª Macro

Sub AdicionarComentarioII()
    Dim sTexto As String
    Dim sPrompt As String
    Dim sTitulo As String
    Dim rCells As Range, rCelula As Range
   'textos
    sPrompt = "Seleciona a(s) celula(s) com o texto a capturar "
    sTitulo = "Adicionar Comentário"
    sTexto = vbNullString
    On Error Resume Next
   'Seleccionar a(s) celula(s) para capturar o texto
    Set rCells = Application.InputBox(sPrompt, sTitulo, Type:=8)
   'testar se existe selecção e se tem uma ou mais celulas
    If rCells Is Nothing Then
        Exit Sub
    ElseIf rCells.Cells.Count > 1 Then
        For Each rCelula In rCells
            If Len(rCelula.Text) > 0 Then _
              sTexto = sTexto & rCelula.Text & Chr(10)
        Next rCelula
    Else
       sTexto = rCells.Text
    End If
    If Len(sTexto) > 0 Then
      'usa a celula activa
        With ActiveCell
         'eliminar comentário caso já exista
          .Comment.Delete
         'Adicionar
          .AddComment
         'Estado do comentário
          .Comment.Visible = False
         'Inserir texto
          .Comment.Text Text:=sTexto
        End With
    End If
End Sub