Auto-Adjusting Graphics

[Mister Mobius]

Hey Guys,

I appreciate any help that anybody can offer. I am making a presentation formatted in Excel, and I have run into a small problem. The presentation has a section that is updated frequently that requires a good bit of time to adjust. What I have in place right now is series of boxes that contain information. I need to have the ability to insert an additional box that can hold information and have the rest of the boxes auto shift down to make room for it. (The list needs to maintain chronological order)

I realize that this is a vague representation of what I need, so please feel free to request more specific information where need and I will do my best to oblige. I appreciate any assistance and/or suggestions.

Best,
August F. Mobius

 

[mrmmickle1]

Would be happy to help out. A few questions. By Boxes do you mean cells? Can you give us some kind of representation of what your data looks like? How is it formatted? How big is the area you want to shift down? Is it in one column? or does it span across several? How many rows does it contain? The more information you can give, the better chance that someone can help you solve your problem.

 

[Mister Mobius]

The boxes I am speaking of are actually graphic inserts that contain text. I am not sure if you are familiar with the municipal bond market, but what I building a list of "tombstones". These tombstones are quick disclosures of past clients. They contain the dollar amount of the bond issuing, the name of the issuer, a small graphic of the municipality, a description of the issuing, the company's role in the bond issuing, and the date that the deal was completed. Whenever new business is done, a new tombstone has to be created and the structure of boxes have to be readjusted manually.
In regard to showing you what I am talking about, I am unable to find a way to share an excel file on this forum and I can't insert the graphics on the tables provided. If you have any ideas on how to provide an example of what I am trying to explain I am all ears.

 

[mrmmickle1]

Mister Mobius,

It is hard to understand your inquiry. What type of graphics are these? Pictures, Shapes, Textboxes? Maybe you can upload a sample file to dropbox, sharesend or filesnack? With all sensitive information removed(If nothing else upload empty "Tombstones"). It would also be helpful if you could include a before sheet and an after sheet with some comments or arrows that include where things are now and where you want them to be after you have added a new "Tombstone" and shifted them down.

 

[Mister Mobius]

I have a workbook ready for you to play with in dropbox. If you could get me your dropbox account name, I'll invite you to the folder.

 

[mrmmickle1]

Mister Mobius,

I have been working on the issue you are having. With the help of AlphaFrog and Rick Rothstein I was able to come up with the below code. The shapes you are referring to are textboxes. I have made a procedure below that should help. If you arrange all of the data on "Sheet2" of your workbook you can use this code and it should autopopulate all textboxes based on the data on Sheet2. I am not quite sure how to get the images to paste into the textboxes but this should be a start. The newly made textboxes will populate on "Sheet1". There are probably better ways to do this but this is what I came up with. Here you go:

Sub InsertTextBoxes2()
    
    Dim r As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim x As Integer
    Dim f As Integer
    Dim lr As Long
    


    lr = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
   
       For k = lr To 2 Step -5


        Rows("1:2").Insert Shift:=xlDown
        Rows("2:2").RowHeight = 130
        
        f = f + 5
        r = lr - f


        For x = r + 4 To r Step -1 
                                   
        i = i + 2
        j = j + 1
    
        With Cells(2, i)
            ActiveSheet.Shapes.AddTextbox msoTextOrientationHorizontal, .Left, .Top, .Width, .Height
        End With

        Sheets("Sheet1").Shapes("TextBox " & j).TextFrame.Characters.Text = Sheets("Sheet2").Range("A" & x).Value _
                  & Chr(13) & Sheets("Sheet2").Range("B" & x).Value & Chr(13) & Sheets("Sheet2").Range("C" & x).Value _
                       & Chr(13) & Sheets("Sheet2").Range("D" & x).Value & Chr(13) & Sheets("Sheet2").Range("E" & x).Value    


     
               Next x
            
            i = 0
       
      Next k 


End Sub

Note: This procedure should be done on test data in a blank workbook. The code won't work properly if there are other existing textboxes in the workbook. (If there are other textboxes in the workbook the code will overwrite the previous textbox values)

 

[Mister Mobius]

I'm going to give it a shot, I'll report back with my results. Thank you so much for your help!

 

[mrmmickle1]

Mister Mobius,

Sorry for the delay. Try this sub procedure in a regular code module. I think it is closer to what you want:

You must:
Have Data on Sheet2 in Database Format (This example assumes 5 Fields of Data)
Put all Pictures on Sheet 1 (Generically Named Picture 1, Picture 2 etc...)

[COLOR=#0000ff]Sub [/COLOR]AlignTombstonePics()
    
   [COLOR=#0000ff] Dim[/COLOR] r  [COLOR=#0000ff]As Integer[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] i  [COLOR=#0000ff]As Integer[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] j  [COLOR=#0000ff]As Integer[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] k[COLOR=#0000ff]  As Integer[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] x[COLOR=#0000ff]  As Integer[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] f  [COLOR=#0000ff]As Integer[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] lr [COLOR=#0000ff]As Long

[/COLOR][COLOR=#0000FF]    On Error Resume Next[/COLOR] 
      
    lr = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
         
      [COLOR=#0000ff]  For[/COLOR] k = lr [COLOR=#0000ff]To[/COLOR] 2 [COLOR=#0000ff]Step[/COLOR] -5
         
      [COLOR=#008000]  'May need to adjust this based on how many fields you are using.  It inserts 7 rows....[/COLOR]
        Rows("1:7").Insert Shift:=xlDown
        Rows("4:4").RowHeight = 100
        
        f = f + 5
        r = lr - f

       [COLOR=#0000ff] For [/COLOR]x = r + 4 [COLOR=#0000ff]To[/COLOR] r [COLOR=#0000ff]Step[/COLOR] -1
        
        i = i + 2
        j = j + 1
             
           [COLOR=#008000] 'Assumes 5 fields.  Pastes Values from Sheet2 to Sheet1[/COLOR]
            [COLOR=#0000ff]With[/COLOR] Sheets("Sheet1")
                .Cells(2, i).Value = Sheets("Sheet2").Range("A" & x).Value
                .Cells(3, i).Value = Sheets("Sheet2").Range("B" & x).Value
                .Cells(5, i).Value = Sheets("Sheet2").Range("C" & x).Value
                .Cells(6, i).Value = Sheets("Sheet2").Range("D" & x).Value
                .Cells(7, i).Value = Sheets("Sheet2").Range("E" & x).Value
         [COLOR=#0000ff]   End With[/COLOR]
                   [COLOR=#008000] 'This aligns the picture to what would hopefully be the center of your "Tombstone"   [/COLOR]         
                    [COLOR=#0000ff]With [/COLOR]Sheets("Sheet1").Shapes.Range(Array("Picture " & j))
                         .Top = Cells(4, i).Top
                         .Left = Cells(4, i).Left
                  [COLOR=#0000ff]  End With
     [/COLOR]
               [COLOR=#0000ff]Next[/COLOR] x
            
            i = 0
            
      [COLOR=#0000ff]Next [/COLOR]k

[COLOR=#0000ff]End Sub[/COLOR]