You're right, if the picture is bigger then the table to be copied it doesn't copy the picture. I can get round it and do so in the code below.
However, there are bigger problems caused by the blank cells in, for example, the New Who sheet at A8, I8 and Q8. It's unusual that there is no header ion these cells. It causes problems with our .SpecialCells; there are more areas than there should be (look at the zzz New Who sheet)
I can get over this too with the code below but you need to confirm that the tables all start in row 2 - ALWAYS.
There's another problem which is difficult, if not impossible to solve, evidenced most clearly in the zzz New What sheet where the picture at cell I1 is squashed. This is because we're trying to put data from different column widths into the same column.
The code:
Sub blah2()
Dim rngToCopy As Range
'Application.CopyObjectsWithCells = True 'if images don't copy over try including this line.
For Each mysht In ActiveWorkbook.Worksheets
If Left(mysht.Name, 6) = "Closed" Or Left(mysht.Name, 3) = "New" Then 'or any other way of excluding sheets you don't want processing.
areaCount = 0 'will keep a tally of areas processed. Used later (odd/even) to decide where to place the next copy on the new sheet (you wanted 2 columns of charts).
Set NewSht = ActiveWorkbook.Sheets.Add(after:=ActiveWorkbook.Sheets(Sheets.Count))
NewSht.Name = "zzz " & mysht.Name 'give the new sheet a name related to the source sheet.
Set Destn = NewSht.Range("A1") 'the top left corner of the new sheet for first pasting.
For Each are In mysht.Rows(2).SpecialCells(xlCellTypeConstants, 7).Areas 'take each area in turn
areaCount = areaCount + 1
Set rngToCopy = are.CurrentRegion
Set rngToCopy = Range(mysht.Cells(1, rngToCopy.Columns(1).Column), rngToCopy.Cells(rngToCopy.Cells.Count)) 'determine what to copy (everything including and above the area, but restricted to the same columns)
For Each pic In mysht.Pictures
Set PicRng = Range(pic.TopLeftCell, pic.BottomRightCell)
If Not Intersect(rngToCopy, PicRng) Is Nothing Then
If PicRng.Columns.Count > rngToCopy.Columns.Count Then
Set rngToCopy = rngToCopy.Resize(, PicRng.Columns.Count) 'this assumes each picture is aligned to the left side of the text to becopied, which it appears to be in your sample.
End If
End If
Next pic
CopyRowHeigths Destn.Resize(rngToCopy.Rows.Count, rngToCopy.Columns.Count), rngToCopy 'copy the row heights of what's being copied to where they're going to be pasted (else pictures would be distorted).
maxRow = Application.Max(maxRow, rngToCopy.Rows.Count) 'will contain the larger number of rows of a pair of paste operations so that the next pair of pasting operations won't overlap any of the previous pair, and they'll stay in line.
rngToCopy.Copy 'put the range into the clipboard
Destn.PasteSpecial xlPasteColumnWidths 'copy the column widths of the source (not always foolproof because the entire column width is affected)
rngToCopy.Copy Destn 'copy everything over
If Application.IsOdd(areaCount) Then 'then it's only the first (left) paste
Set Destn = Destn.Offset(, rngToCopy.Columns.Count) 'so set the new Destination to the same row but the number of columns just pasted to the right
Else 'we've just pasted the second of a pair (right), so set the next Destination to be in column A, but the max number of rows (of the two recent pasted ranges) below the last destination.
Set Destn = NewSht.Cells(Destn.Row + maxRow, "A")
maxRow = 0 'reset maxrow to zero as we'll be processing a fresh pair.
End If
Next are 'next area on the source sheet
End If
Next mysht 'next sheet in the active workbook
End Sub