Create word table and auto-fill images

createpicturetable.vba

'Create the following Word Macro:
Sub InsertMultipleImages()
Dim fd As FileDialog
Dim oTable As Table
Dim sNoDoc As String
Dim vrtSelectedItem As Variant
Dim Counter As Integer
If Documents.Count = 0 Then
sNoDoc = MsgBox(" " & _
"No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images")
If sNoDoc = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
'add a 1 row 2 column table to take the images
'Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then

'Add a table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, .SelectedItems.Count, 2)
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Cell(1, 1).Select
Counter = 1
For Each vrtSelectedItem In .SelectedItems
oTable.Cell(Counter, 1).Select
With Selection
.InlineShapes.AddPicture FileName:= _
vrtSelectedItem _
, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range
.MoveRight Unit:=wdCell
End With
Counter = Counter + 1
Next vrtSelectedItem
Else
End If
End With
If Len(oTable.Rows.Last.Cells(1).Range) = 2 Then
oTable.Rows.Last.Delete
End If
Set fd = Nothing
End Sub