Sub Skype_Reformatter()
Application.ScreenUpdating = False
Dim Rng As Range, StrFnd As String
With ActiveDocument.Content
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "([!^13])(\[[0-9]{1,2}/[0-9]{1,2}/[0-9]{4})"
    .Replacement.Text = "^p\2"
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = True
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    StrFnd = .Text
    Set Rng = .Paragraphs.First.Range.Duplicate
    With Rng
      On Error GoTo ParaLast
      Do
        .Text = Replace(.Text, StrFnd, "")
        If InStr(.Paragraphs.Last.Next.Range.Text, StrFnd) = 2 Then
          .MoveEnd wdParagraph, 1
        Else
          Exit Do
        End If
      Loop
ParaLast:
      ActiveDocument.Sections.Add Range:=Rng, Start:=wdSectionContinuous
      .InsertBefore vbCr & Format(StrFnd, "d") & " de " & Format(StrFnd, "mmmm")
      .Paragraphs.First.Next.Style = "Heading 3"
    End With
    .Start = Rng.End
    .Find.Execute
  Loop
  .Start = 0
  With .Find
    .Text = "(\[ [0-9]{1,2}:[0-9]{1,2}:[0-9]{1,2}\])"
    .Execute
  End With
  Do While .Find.Found
    With .Words.Last.Next.Words.First
      .Text = UCase(Trim(Left(.Text, 1)))
      .Font.Bold = True
    End With
    .Text = Format(Mid(.Text, 3, Len(.Text) - 4), "h:mm AMPM")
    .Font.Italic = True
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub