How to re-order pictures in a table using Word VBA?

[bonniek]

I have a 2x4 table in word with pictures in cells and captions in the cell below something similar to this;


Picture 1
Picture 2


Caption 1
Caption 2


Picture 3
Picture 4


Caption 3
Caption 4




I am trying to figure out a method to sort the table if one picture and associated caption gets deleted, the one after it will takes its place. Lets say we delete picture 3 so table would look something like this;


Picture 1
Picture 2


Caption 1
Caption 2


Picture 4


Caption 4




I have this code so far which will delete the cells for picture and caption but it wouldn't reorder the table. After the code is run, the table looks like this if picture 3 and caption is deleted;


Picture 1
Picture 2


Caption 1
Caption 2



Picture 4



Caption 4




CODE:

Sub ProcCells1()
Dim tTable As Table
Dim cCell As Cell

For Each tTable In ActiveDocument.Range.Tables
For Each cCell In tTable.Range.Cells
'An apparently empty cell contains an end of cell marker
If Len(cCell.Range.Text) < 3 Then
cCell.Delete

End If
Next
Next
Set oCell = Nothing
Set tTable = Nothing

End Sub

I have an idea in mind where I would assign every photo&caption to an array and then copy&paste the photo&caption to each member of an array but I am not sure about how to tackle it.

[gmaxey]

Crude but seems to work:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oColImage As Collection, oColCaption As Collection
Dim oCell As Word.Cell
Dim oRng As Range
Dim lngIndex As Long, lngCol As Long, lngCol2 As Long
Dim oTbl As Word.Table
For Each oTbl In ActiveDocument.Tables
lngCol = 0: lngCol2 = 0
Set oColImage = New Collection
Set oColCaption = New Collection
For Each oCell In oTbl.Range.Cells
If Len(oCell.Range.Text) > 2 Then
Set oRng = oCell.Range.Duplicate
oRng.End = oRng.End - 1
oRng.Select
If oCell.Row.Index Mod 2 = 1 Then
oColImage.Add oRng
Else
oColCaption.Add oRng
End If
End If
Next oCell
On Error GoTo Handler
For lngIndex = 1 To oTbl.Range.Cells.Count
Set oCell = oTbl.Range.Cells(lngIndex)
Set oRng = oCell.Range.Duplicate
oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
lngCol = lngCol + 1
oColImage.Item(lngCol).Copy
oRng.Paste
Else
lngCol2 = lngCol2 + 1
oRng.Text = oColCaption.Item(lngCol2).Text
End If
ReEntry:
Next lngIndex
Next oTbl
lbl_Exit:
Exit Sub
Handler:
oCell.Delete
Resume ReEntry:
End Sub

[gmaxey]

This is more complicated than it first appeared. Try this and let me know if there are issues. I just don't have any more time to continue testing:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oColImage As Collection, oColCaption As Collection
Dim oCell As Word.Cell
Dim oRng As Range
Dim lngIndex As Long, lngCol As Long, lngCol2 As Long, lngContent, lngEmpty
Dim oTbl As Word.Table
For Each oTbl In ActiveDocument.Tables
lngCol = 0: lngCol2 = 0
Set oColImage = New Collection
Set oColCaption = New Collection
For Each oCell In oTbl.Range.Cells
If Len(oCell.Range.Text) > 2 Then
lngContent = lngContent + 1
Set oRng = oCell.Range.Duplicate
oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
oColImage.Add oRng
Else
oColCaption.Add oRng
End If
End If
Next oCell
On Error GoTo Handler
For lngIndex = 1 To oTbl.Range.Cells.Count
Set oCell = oTbl.Range.Cells(lngIndex)
Set oRng = oCell.Range.Duplicate
oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
lngCol = lngCol + 1
oRng.InsertXML oColImage.Item(lngCol).WordOpenXML
oRng.Characters.Last.Next.Delete
Else
lngCol2 = lngCol2 + 1
oRng.Text = oColCaption.Item(lngCol2).Text
End If
ReEntry:
Next lngIndex
lngEmpty = oTbl.Range.Cells.Count - lngContent
For lngIndex = 1 To lngEmpty Step 2
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index, oTbl.Columns.Last.Index)
oCell.Delete
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index - 1, oTbl.Columns.Last.Index)
oCell.Delete
Next
Next oTbl
lbl_Exit:
Exit Sub
Handler:
Resume ReEntry:
End Sub

[bonniek]

This is more complicated than it first appeared. Try this and let me know if there are issues. I just don't have any more time to continue testing:


Thanks a lot for the help, Greg! I have tried it with a table however it keeps freezing and I have to use ctrl-break to get out of it. Any idea what might be triggering that? Thanks again.

[gmaxey]

It worked here on a table like your sample above. Can you attach a file containing a problem table?

[bonniek]

Hi Greg,

I tried the code again and it seems to work if 1 picture is deleted however I cant figure out why it completely freezes when 2 pictures are deleted. Usually when it freezes I have to get out using ctrl+break.

Another interesting tidbit I noticed was that the code works great with word 2007 but the pictures completely disappear when I run it with 2016.

Thank again for your help.

16814

[gmaxey]

bonniek,

I really don' know why the .InsertXML method doesn't work in Word 2016. Don't know enough about it.

This works for 1, 2 or more deleted picture/caption pairs (in Word 2016):


Sub ScratchMacro()
Dim oColImage As Collection, oColCaption As Collection
Dim oCell As Word.Cell
Dim oRng As Range
Dim lngIndex As Long, lngCol As Long, lngCol2 As Long, lngContent, lngEmpty
Dim oTbl As Word.Table

For Each oTbl In ActiveDocument.Tables
lngCol = 0: lngCol2 = 0
Set oColImage = New Collection
Set oColCaption = New Collection
For Each oCell In oTbl.Range.Cells
If Len(oCell.Range.Text) > 2 Then
lngContent = lngContent + 1
Set oRng = oCell.Range.Duplicate
'oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
oColImage.Add oRng
Else
oColCaption.Add oRng
End If
End If
Next oCell
On Error GoTo Handler
For lngIndex = 1 To oTbl.Range.Cells.Count
Set oCell = oTbl.Range.Cells(lngIndex)
Set oRng = oCell.Range.Duplicate
'oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
lngCol = lngCol + 1
oColImage.Item(lngCol).Copy
'oRng.Delete
oRng.Paste
'oRng.InsertXML oColImage.Item(lngCol).WordOpenXML
'oRng.Characters.Last.Next.Delete
Else
lngCol2 = lngCol2 + 1
oRng.Text = oColCaption.Item(lngCol2).Text
End If
ReEntry:
Next lngIndex
lngEmpty = oTbl.Range.Cells.Count - lngContent
On Error GoTo 0
For lngIndex = 1 To lngEmpty Step 2
Set oRng = oTbl.Range.Cells(oTbl.Range.Cells.Count).Range
lngCol = oRng.Information(wdEndOfRangeColumnNumber)
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index - 1, lngCol)
oCell.Delete
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index, lngCol)
oCell.Delete
Next
Next oTbl
lbl_Exit:
Exit Sub
Handler:
Resume ReEntry:
End Sub

[gmaxey]

This version processes both Word 2010 and Word 2016. I still haven't figured out why the InsertXML process doesn't work as expected in Word 2016.


Sub CloseUpEmptyCells()
Dim oColImage As Collection, oColCaption As Collection
Dim oCell As Word.Cell
Dim oRng As Range
Dim lngIndex As Long, lngCol As Long, lngCol2 As Long, lngContent, lngEmpty
Dim oTbl As Word.Table

For Each oTbl In ActiveDocument.Tables
lngCol = 0: lngCol2 = 0
Set oColImage = New Collection
Set oColCaption = New Collection
For Each oCell In oTbl.Range.Cells
If Len(oCell.Range.Text) > 2 Then
lngContent = lngContent + 1
Set oRng = oCell.Range.Duplicate
If oCell.Row.Index Mod 2 = 1 Then
If Application.Version < 15 Then oRng.End = oRng.End - 1
oColImage.Add oRng
Else
oRng.End = oRng.End - 1
oColCaption.Add oRng
End If
End If
Next oCell
On Error GoTo Handler
For lngIndex = 1 To oTbl.Range.Cells.Count
Set oCell = oTbl.Range.Cells(lngIndex)
Set oRng = oCell.Range.Duplicate
If Application.Version < 15 Then oRng.End = oRng.End - 1
If oCell.Row.Index Mod 2 = 1 Then
lngCol = lngCol + 1
If Application.Version > 14 Then
oColImage.Item(lngCol).Copy
oRng.Paste
Else
oRng.InsertXML oColImage.Item(lngCol).WordOpenXML
oRng.Characters.Last.Next.Delete
End If
Else
lngCol2 = lngCol2 + 1
oRng.Text = oColCaption.Item(lngCol2).Text
End If
ReEntry:
Next lngIndex
lngEmpty = oTbl.Range.Cells.Count - lngContent
On Error GoTo 0
For lngIndex = 1 To lngEmpty Step 2
Set oRng = oTbl.Range.Cells(oTbl.Range.Cells.Count).Range
lngCol = oRng.Information(wdEndOfRangeColumnNumber)
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index - 1, lngCol)
oCell.Delete
Set oCell = oTbl.Cell(oTbl.Rows.Last.Index, lngCol)
oCell.Delete
Next
Next oTbl
lbl_Exit:
Exit Sub
Handler:
Resume ReEntry:
End Sub

[bonniek]

Greg,

Sorry to revive an old thread again. I am running into an issue with output after running the macro.

Originally, the captions in the tables are inserted using "Insert caption" feature which adds an automatic field: {Seq Picture *\ARABIC}. This allows caption and associated picture numbers to be updated after the fact. After running the macro, the automatic field is turned into static text so the caption numbers don't automatically update.

I think the breakdown is happening when the text is copied into the collection item. I have tried turning on field display using alt+f9 before running the macro so it will copy the field however it still breaks down.

I have tried using arrays instead of collection but I am lost for which direction to take the code to make it work so it will retain the automatic caption/field.

Any idea on how to approach this problem?