I have been searching and found many macros to auto-organized pictures into tables and add captions, but none with multiple pictures to one caption. Also, I want to be able to auto format pictures already on the page. I'd like to thank MacroPod for his help in getting me started with ideas of selecting and using inline shapes pictures to a table. I described in the code what my intentions are. Hopefully, my mess of code is understandable and can be salvaged. I'm MacroNoob for a reason. Thanks for any help in advance.








	
Sub SelectorImagetoTable()

Application.ScreenUpdating = False
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long
With ActiveDocument
 'looks at each page and counts how many pictures
  For i = 1 To .ComputeStatistics(wdStatisticPages)
    Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    If i = .ComputeStatistics(wdStatisticPages) Then
        Rng.End = .Range.End
    End If
    With Rng
      Select Case .ShapeRange.Count
                
                
                Case 1
                'if only one picture on the page
          With .ShapeRange(1)
                'dimensions of the picture
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(5)
                'location of picture
            .Left = InchesToPoints(0.55)
            .Top = InchesToPoints(3.13)
          End With
      Set Rng = .InlineShapes(i).Range
      With Rng
         If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
                'insert picture in row 1 column 1 and caption in row 2 column 1
      Set Tbl = .Tables.Add(Range:=Rng, NumRows:=2, NumColumns:=1)
      With Tbl
         .Cell(1, 1).Range.Paste
        Set Rng = .Cell(2, 1).Range
        With Rng
          .Style = "Caption"
          .End = .End - 1
          .InsertAfter vbCr
          .InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
            Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
          .Characters.First.Text = vbNullString
          .Paragraphs.First.Range.Characters.Last.Text = vbNullString
          'I had this working in a former macro for dimesion/
            'location of caption...how would I implement?
            'Set Box = ActiveDocument.Shapes.AddTextbox( _
             '   Orientation:=msoTextOrientationHorizontal, _
             '   Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
             '   Box.TextFrame.TextRange.Text = "Fig. "
            'End With
        End With
                'no boarders on any boxes for clean look
        .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
        .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
        .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
        .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
        .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
        .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Columns.Width = InchesToPoints(5)
      End With
      
      
      Case 2
         'if only one picture on the page
          With .ShapeRange(2)
                'dimensions/location of picture 1 and 2
            With .ShapeRange(1)
                'Problem ^ selecting the shape.
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(5)
            .Left = InchesToPoints(0.55)
            .Top = InchesToPoints(1.55)
            End With
            With .ShapeRange(2)
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(5)
            .Left = InchesToPoints(0.55)
            .Top = InchesToPoints(5.55)
            End With
          End With
      Set Rng = .InlineShapes(i).Range
      With Rng
         If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
                'insert picture 1 in row 1 and picture 2 into row 2
                'insert caption in row 3
      Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=1)
      With Tbl
         .Cell(1, 1).ShapeRange(1).Paste
         .Cell(2, 1).ShapeRange(2).Paste
        Set Rng = .Cell(3, 1).Range
        With Rng
          .Style = "Caption"
          .End = .End - 1
          .InsertAfter vbCr
          .InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
            Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
          .Characters.First.Text = vbNullString
          .Paragraphs.First.Range.Characters.Last.Text = vbNullString
             'Set Box = ActiveDocument.Shapes.AddTextbox( _
             '   Orientation:=msoTextOrientationHorizontal, _
             '   Left:=0.44, Top:=9.3, Width:=5.18, Height:=0.44)
             '   Box.TextFrame.TextRange.Text = "Fig. "
            'End With
        End With
                'no boarders on any boxes for clean look again
        .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
        .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
        .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
        .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
        .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
        .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Columns.Width = InchesToPoints(5)
      End With
                      
                      
        Case 3
         'if there are 3 picture on the page
          With .ShapeRange(3)
                'dimensions/location of picture 1 and 2
          With .ShapeRange(1)
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(4.6)
            .Left = InchesToPoints(0.27)
            .Top = InchesToPoints(0.25)
          End With
          With .ShapeRange(2)
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(4.6)
            .Left = InchesToPoints(0.27)
            .Top = InchesToPoints(3.75)
          End With
          With .ShapeRange(3)
            .LockAspectRatio = msoTrue
            .Width = InchesToPoints(4.6)
            .Left = InchesToPoints(0.27)
            .Top = InchesToPoints(7.25)
          End With
          End With
      Set Rng = .InlineShapes(i).Range
      With Rng
         If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
                'insert pic 1 =row 1, pic 2 =row 2, and pic 3 =row 3
                'insert caption in row 1 column 2
      Set Tbl = .Tables.Add(Range:=Rng, NumRows:=3, NumColumns:=2)
      With Tbl
         .Cell(1, 1).ShapeRange(1).Paste
         .Cell(2, 1).ShapeRange(2).Paste
         .Cell(3, 1).ShapeRange(3).Paste
        Set Rng = .Cell(1, 2).Range
        With Rng
          .Style = "Caption"
          .End = .End - 1
          .InsertAfter vbCr
          .InsertCaption Label:="Fig.", TitleAutoText:="InsertCaption1", _
            Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
          .Characters.First.Text = vbNullString
          .Paragraphs.First.Range.Characters.Last.Text = vbNullString
            'I had this working in a former macro for dimesion/
            'location of caption...how would I implement?
            'Set Box = ActiveDocument.Shapes.AddTextbox( _
             '   Orientation:=msoTextOrientationHorizontal, _
             '   Left:=4.5, Top:=0.7, Width:=2.5, Height:=1.5)
             '   Box.TextFrame.TextRange.Text = "Fig. "
            'End With
                'no boarders on any boxes for clean look again
        .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
        .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
        .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
        .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
        .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
        .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Columns.Width = InchesToPoints(5)
      End With
                
End Sub