Sub MACRO5()
Dim shpGroup As ShapeRange
Dim C As Shape, L As Shape, R As Shape
Dim oPar As Paragraph
Dim oRng As Range
Dim oShp As Shape

  For Each oPar In ActiveDocument.Paragraphs
    If oPar.Range.ShapeRange.Count > 0 Then
      'The ShapeRanges in this document are anchored to the first paragraph in the sections.
      Set oRng = oPar.Range
      'Now we need to move the range down to the paragraph of interest e.g., the second or third
      'paragraphs covered by the shape range (or where you previoiusly had them anchored)
      Do Until Len(oRng.Paragraphs(1).Range.Text) > 1
        oRng.Move wdParagraph, 1
      Loop
      'We have now found the first paragraph with text.  Some of your shaperanges have three lines
      'where the second line is very small and formatted with a font named "Fb Livorna"
      If oRng.Paragraphs.Last.Next.Range.Font.Name = "Fb Livorna" Then
        'Move down 2 paragrphs.
        oRng.Move wdParagraph, 2
      Else
        'Your fourth shape does not have the "Fb Livorna" paragraph
        oRng.Move wdParagraph, 1
      End If
      'Now we have the paragraph of interest and need to determine how wide the
      'center shape should be.  This is a convoluted process and perhaps due to your right to left text,
      'or styles applied.  Regardless it works here.
      oRng.Paragraphs(1).Range.Characters.Last.Previous.Select
      PRINCIPIO = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
      oRng.Paragraphs(1).Range.Characters(1).Select
      Selection.EndKey
      FIN = Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
      TAMANO = PRINCIPIO - FIN
      oPar.Range.ShapeRange(1).Select
      Set shpGroup = Selection.ShapeRange
      shpGroup.Ungroup
      For Each oShp In shpGroup
         If oShp.Name = "1" Then Set L = oShp
         If oShp.Name = "2" Then Set C = oShp
         If oShp.Name = "3" Then Set R = oShp
      Next
      C.LockAspectRatio = msoFalse
      C.Width = TAMANO
      C.Left = C.Left - ADDITION_IN_EACH_SIDE
      L.Left = C.Left - L.Width
      R.Left = C.Left + C.Width
     shpGroup.Group
     shpGroup.Left = wdShapeCenter
     End If
  Next
lbl_Exit:
  Exit Sub
End Sub

Sub Resize3PartShapeToText()
Dim oPar As Paragraph
Dim shpGroup As ShapeRange
Dim C As Shape, L As Shape, R As Shape
Dim oRng As Range, oRngEval As Range
Dim oShp As Shape
Dim lngPositStart As Long, lngPositEnd As Long
  Application.ScreenUpdating = False
  For Each oPar In ActiveDocument.Paragraphs
    If oPar.Range.ShapeRange.Count > 0 Then
      If oPar.Range.ShapeRange(1).Name = "Banner" Then
        Set oRng = oPar.Range
        oRng.Select
        Do Until Len(oRng.Paragraphs(1).Range.Text) > 1
          'Finds the Fixed Line
          oRng.Move wdParagraph, 1
        Loop
        'Get the variable text line.
        oRng.Move wdParagraph, 1
        Set oRngEval = oRng.Paragraphs(1).Range.Duplicate
        oRngEval.Collapse wdCollapseStart
        lngPositStart = oRngEval.Information(wdHorizontalPositionRelativeToTextBoundary)
        Set oRngEval = oRng.Paragraphs(1).Range.Duplicate
        oRngEval.Collapse wdCollapseEnd
        oRngEval.Move wdCharacter, -1
        lngPositEnd = oRngEval.Information(wdHorizontalPositionRelativeToTextBoundary)
        Set shpGroup = oPar.Range.ShapeRange
        shpGroup.Ungroup
        For Each oShp In shpGroup
          Select Case oShp.Name
            Case "Left": Set L = oShp
            Case "Center": Set C = oShp
            Case "Right": Set R = oShp
          End Select
        Next
        C.LockAspectRatio = msoFalse
        C.Width = lngPositEnd - lngPositStart
        C.Left = C.Left
        L.Left = C.Left - L.Width
        R.Left = C.Left + C.Width
        shpGroup.Group
        shpGroup.Name = "Banner"
        shpGroup.Left = wdShapeCenter
        shpGroup.Height = 99.5
      End If
    End If
  Next
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub