Consulting

Results 1 to 15 of 15

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

  1. #1
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location

    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:
    Multiple ranges of cells BEFORE.JPG

    My manager's goal is to have it arranged vertically, to look like this:
    Multiple ranges of cells AFTER.JPG

    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?

  2. #2
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,430
    Try (with only a single unmerged cell selected beforehand) F5 on the keyboard and click Special… then select as follows:
    2019-04-23_201757.jpg
    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.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,390
    Location
    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


    Capture.JPG



    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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):
    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

  5. #5
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,430
    This blah macro is meant to copy from the active sheet to a new sheet that it will create:
    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
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  6. #6
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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

  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,430
    Yes:
    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).
    Last edited by p45cal; 04-24-2019 at 07:42 AM.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  8. #8
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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.

  9. #9
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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.

  10. #10
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,430
    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.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  11. #11
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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:

    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)
    Attached Files Attached Files

  12. #12
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,430
    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
    Last edited by p45cal; 05-14-2019 at 02:37 PM.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  13. #13
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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." I don't care. The solutions I'm learning from your code are invaluable. I'll report back tomorrow. Cheers

  14. #14
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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.

  15. #15
    VBAX Regular
    Joined
    Mar 2019
    Posts
    29
    Location
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •