VBA to dynamically select EACH block/range of cells on a worksheet, then copy/paste?

I'm working with data that comes from Business Objects. I cannot control the output format. Currently, the data is exported as several charts (that come through as picture objects) and several (sorta)tables. The chart picture objects are (mostly) all next to each other, horizontally across the sheet. The (sorta)tables are all in the row(s) beneath the chart picture objects. It looks like this:
Attachment 24122

My manager's goal is to have it arranged vertically, to look like this:
Attachment 24123

She wants each (sorta)table copied/pasted as a picture object. So, in English, the steps go like this:

• Evaluate the current cell
• If it is not blank, select the entire range of contiguous cells, copy it, paste it as a picture
• Go to the next non-blank cell that's NOT a part of the current range, select that new range, copy, paste
• Repeat until all (sorta)tables are pasted as pictures
• Go to the next sheet, continue evaluating

I can say it in English just fine....translating that to VBA is another matter entirely. I've tried working with CurrentRegion, end(xltoright), named ranges, etc. I have reached various levels of success, but am still falling short. Any suggestions?

Try (with only a single unmerged cell selected beforehand) F5 on the keyboard and click Special… then select as follows:
Attachment 24124
and click OK. If you get discrete areas more or less corresponding to the tables, then we should be able to iterate through those areas fishing for picture objects above each of them.
Best to attach a workbook rather than pictures.

It'll help a lot if you can attach a sample workbook with the Before and the After

Fake any data that might be sensitive


A non-VBA solution which you might prefer would be to use the Camera Tool which basically takes a picture of a range of cells (A1:F6 in my attachment) and allows you to paste it as an updating picture

https://trumpexcel.com/excel-camera-tool/

Simple example attached


Attachment 24125

Holy moly!! I've never used GoTo> Special > Constant....as you predicted, that DID select all the necessary ranges!!

Two other things, since my last post:
►I'm attaching the output file here, so it will be easier to see what we're dealing with
►I DID finally cobble together some code that works - HOWEVER, because of what I suspect is a "race condition" (as in "running", not "country you're from"...lol), it will periodically fail at the "Range("A16").PasteSpecial " line. I'm not sure what to do to stop that.

Here is the code (but please don't let that deter you from improving upon what I've come up with):

Code:

---

Sub FindAll()


'PURPOSE: Find all cells containing a specified value




Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range


'What value do you want to find (must be in string form)?
  fnd = "Total"  'Enter what you're looking for here


Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell, LookIn:=xlValues, lookat:=xlWhole) 'xlWhole will allow search for JUST the word "Total" and NOT something like "Total Incurred"
'Test to see if anything was found
  If Not FoundCell Is Nothing Then
    FirstFound = FoundCell.Address
  Else
    GoTo NothingFound
  End If


Set rng = FoundCell
'FoundCell.Select


'Loop until cycled through all unique finds
  Do Until FoundCell Is Nothing
   
    FoundCell.currentregion.CopyPicture
    DoEvents
    Range("A16").PasteSpecial
    DoEvents
   
    'Find next cell with fnd value
      Set FoundCell = myRange.FindNext(after:=FoundCell)
        DoEvents
    'Add found cell to rng range variable
      'Set rng = Union(rng, FoundCell)
   
    'Test to see if cycled through to first found cell
      If FoundCell.Address = FirstFound Then Exit Do
     
  Loop


'Select Cells Containing Find Value
  'rng.Select
MsgBox "Macro is done"
 
Exit Sub


'Error Handler
NothingFound:
  MsgBox "No values were found in this worksheet"


End Sub

---

This blah macro is meant to copy from the active sheet to a new sheet that it will create:

Code:

---

Sub blah()
Dim rngToCopy As Range
'Application.CopyObjectsWithCells = True 'if images don't copy over try including this line.
areaCount = 0
Set mySht = ActiveSheet
Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
Set Destn = NewSht.Range("A1")
For Each are In mySht.Cells.SpecialCells(xlCellTypeConstants, 7).Areas
  areaCount = areaCount + 1
  Set rngToCopy = Range(mySht.Cells(1, are.Columns(1).Column), are.Cells(are.Cells.Count))
  CopyRowHeigths Destn.Resize(rngToCopy.Rows.Count, rngToCopy.Columns.Count), rngToCopy
  maxRow = Application.Max(maxRow, rngToCopy.Rows.Count)
  rngToCopy.Copy
  Destn.PasteSpecial xlPasteColumnWidths
  rngToCopy.Copy Destn
  If Application.IsOdd(areaCount) Then
    Set Destn = Destn.Offset(, rngToCopy.Columns.Count)
  Else
    Set Destn = NewSht.Cells(Destn.Row + maxRow, "A")
    maxRow = 0
  End If
Next are
End Sub

Private Sub CopyRowHeigths(TargetRange As Range, SourceRange As Range)
Dim r As Long
    With SourceRange
        For r = 1 To .Rows.Count
            TargetRange.Rows(r).RowHeight = .Rows(r).RowHeight
        Next r
    End With
End Sub

---

Wow. I'm blown away. This is great. Can I just add a For Each to have it loop through and execute on all the worksheets? Also, if you wouldn't mind, I'd LOVE to have any kind of explanation you're willing to offer, for what each section of code is actually executing. Oh, and, what is "are"? When I first saw it, I thought perhaps it was meant to be "area" and you just forgot a letter:) But now I see that it was intentional and that it works. I can't thank you enough. I was ready to give up entirely:bow:

Yes:

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.Cells.SpecialCells(xlCellTypeConstants, 7).Areas 'take each area in turn
      areaCount = areaCount + 1
      Set rngToCopy = Range(mySht.Cells(1, are.Columns(1).Column), are.Cells(are.Cells.Count)) 'determine what to copy (everything including and above the area, but restricted to the same columns)
      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

---

See comments in the code for short explanations.

Yes, are is of my choosing.
Normally I try to use the singular of a collection of things except when it could confuse with a reserved word in VBA
eg. For each worm in CanOfWorms
For each City in Cities
So I could have used:
for each Area in mySht.Cells.SpecialCells(xlCellTypeConstants, 7).Areas
but Area is a reserved word (it might work but it's confusing).

Outstanding. I hope to someday know my way around VBA like you do...until then, thank goodness for boards like this one and people like you. I can't thank you enough.

p45cal - i"m hoping you see this. I sent you a private message. I'm having a small issue with the code above. I'm fairly certain it will be an easy answer, but I'm not sure. All the details are in the message. The gist of it is this: The original data that you used to help me design this procedure was based on a 5-year data sample. We also run the same queries using 3 years of data. I believe it is that difference that's causing the issue - and the issue is that some of the picture objects are now not pasting over to the newly created worksheets. Some of them ARE making it over, though. Any ideas you can suggest would be very much appreciated. I'll post the solution here, in case it helps others who might be interested.

First, did you not notice the line:
'Application.CopyObjectsWithCells = True 'if images don't copy over try including this line.
Have you tried enabling it by removing the first apostrophe?

If that fails I've got to see the workbook - attach it here.

I did see that line and it didn't help. I think I know the issue, though. With the 3-years of data, there are fewer columns in the table, so now the charts are wider than the number of columns that contain the table data. I just realized that, if you don't select the ENTIRE chart/picture before copying, it won't actually copy it. So, I've zeroed in on this line of code that likely needs to be addressed - HOW to address it is not clear to me:

Code:

---

Set rngToCopy = Range(mysht.Cells(1, are.Columns(1).Column), are.Cells(are.Cells.Count)) 'determine what to copy (everything including and above the area, but restricted to the same columns)

---

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:

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

---

Thank you very much for working on this. I did create another bit of code (called near the start of the script) that fills in any blanks, so hopefully that mitigates that issue.

Yes, the tables will always start in row 2.

As for the last issue you point out, I see what you're saying. I have to leave for the day now, but I'm going to try out what you've written above first thing tomorrow, to see if I get the same results as you.

And, of course, as each step toward progress is made, I can hear my boss in her office, thinking out loud about how "perhaps this isn't the best way to handle this data." :banghead: I don't care. The solutions I'm learning from your code are invaluable. I'll report back tomorrow. Cheers :)

This is fantastic. I could've worked on this for the next 30 years and I wouldn't have solved my issue. Thank you, thank you, thank you. My boss is now toying with the idea of taking each chart/table combo and instead pasting them into individual slides in PowerPoint. God help us all.

Hi p45cal - Well,she did it. My boss has decided that each chart/table combo should be copied/pasted as pictures to PowerPoint, one combo per slide. I'm going to start a new thread because, while I have managed to MOSTLY accomplish this on my own, there are a couple quirky things that I can't get past. I'm posting this message here because I'm hoping you'll take a look at the new post :)