Solved

excel 2007 image

Posted on 2014-10-26
10
112 Views
Last Modified: 2014-11-26
Have images auto copied from one excel file to another. Once images copied into the destination master excel file, need to run VBA to auto-size image and center inside cell.
0
Comment
Question by:Hank11
  • 5
  • 4
10 Comments
 
LVL 3

Expert Comment

by:Sandeep Khanagwal
Comment Utility
0
 

Author Comment

by:Hank11
Comment Utility
We already have VBA that copies images from one xls to another xls where it places them in the correct corresponding cell in the upper left corner.  After copying to destination (which works great), some images are larger than the cell and hang over the cell - while other images are smaller than the cell and we want enlarge to fit in the cell.  The cells are formatted to be the same size since this is a report.
0
 
LVL 20

Expert Comment

by:Ejgil Hedegaard
Comment Utility
Insert this in a module.

Option Explicit

Sub FitPictureToCell()
    Dim ws As Worksheet
    Dim sh As Shape
    Dim rw As Integer, col As Integer
    Dim rg As Range
    Dim rwHeigth As Single, colWidth As Single
    
    Set ws = Worksheets("QA")
    Application.ScreenUpdating = False
    For Each sh In ws.Shapes
        If sh.TopLeftCell.Row > 1 Then
            rw = sh.TopLeftCell.Row
            col = sh.TopLeftCell.Column
            Set rg = ws.Range(Cells(rw, col), Cells(rw, col))
            rwHeigth = ws.Rows(rw).Height
            colWidth = ws.Columns(col).Width
            If col = 2 Then
                colWidth = colWidth + ws.Columns(col + 1).Width
            End If
            If sh.Height / rwHeigth > sh.Width / colWidth Then
                sh.Height = rwHeigth - 2
            Else
                sh.Width = colWidth - 2
            End If
            sh.Top = rg.Top + (rwHeigth - sh.Height) / 2
            sh.Left = rg.Left + (colWidth - sh.Width) / 2
        End If
    Next sh
    Application.ScreenUpdating = True
End Sub

Open in new window

0
 

Author Comment

by:Hank11
Comment Utility
You cleaned up the row adjustment module.  Can this be included as part of that execution? Rows and Pics? If so, how would I ass this code to that module?
0
 
LVL 20

Accepted Solution

by:
Ejgil Hedegaard earned 500 total points
Comment Utility
Replace all in the row adjustment module with this, or insert in another module.
Change the macro for the button "Auto Row Adj".
Right click on button and attach the macro.

Option Explicit

Sub Auto_Row_Height_Picture_Fit()
    Dim rw As Integer, rwMax As Integer, col As Integer
    Dim MrgAddr As String
    Dim rngMergeArea As Range, c As Range
    Dim MrgWidth As Double, rwHeight As Double, cellWidth As Double, colWidth As Single
    Dim ws As Worksheet
    Dim sh As Shape
    Dim PictureNbr As Integer, PictureTotalNbr As Integer
    Dim rg As Range
    
    Set ws = Worksheets("QA")
    Application.ScreenUpdating = False
    
    'Adjust row height in rows with Status in column B
    rwMax = ws.UsedRange.Rows.Count
    frmStatus.Show vbModeless
    frmStatus.Label1 = "Adjusting row height for Status"
    For rw = 1 To rwMax
        If Range("B" & rw) = "Status" Then
            frmStatus.Label2 = "Row " + CStr(rw) + " of " + CStr(rwMax)
            DoEvents
            MrgAddr = Range("C" & rw).MergeArea.Address
            Set rngMergeArea = Range(MrgAddr)
            With rngMergeArea
                .UnMerge
                cellWidth = .Cells(1).ColumnWidth
                MrgWidth = 0
                For Each c In rngMergeArea
                    c.WrapText = True
                    MrgWidth = c.ColumnWidth + MrgWidth
                Next
                .Cells(1).ColumnWidth = MrgWidth
                .EntireRow.AutoFit
                rwHeight = .RowHeight
                .Cells(1).ColumnWidth = cellWidth
                .MergeCells = True
                .RowHeight = rwHeight
            End With
        End If
    Next rw
    
    'Adjust pictures to fit in cells
    frmStatus.Label1 = "Adjusting picture to fit in cells"
    PictureTotalNbr = ws.Shapes.Count
    PictureNbr = 0
    For Each sh In ws.Shapes
        If sh.TopLeftCell.Row > 1 Then
            PictureNbr = PictureNbr + 1
            frmStatus.Label2 = "Picture number " + CStr(PictureNbr) + " of " + CStr(PictureTotalNbr)
            DoEvents
            rw = sh.TopLeftCell.Row
            col = sh.TopLeftCell.Column
            Set rg = ws.Range(Cells(rw, col), Cells(rw, col))
            rwHeight = ws.Rows(rw).Height
            colWidth = ws.Columns(col).Width
            If col = 2 Then
                colWidth = colWidth + ws.Columns(col + 1).Width
            End If
            If sh.Height / rwHeight > sh.Width / colWidth Then
                sh.Height = rwHeight - 2
            Else
                sh.Width = colWidth - 2
            End If
            sh.Top = rg.Top + (rwHeight - sh.Height) / 2
            sh.Left = rg.Left + (colWidth - sh.Width) / 2
        End If
    Next sh
    Application.ScreenUpdating = True
    Unload frmStatus
End Sub

Open in new window

0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 

Author Comment

by:Hank11
Comment Utility
Ejgil,

I'm getting a Run-time error '5' "Invalid procedure call or argument" on the weekly master file.  When I debug, it highlights "FilenameAgent = Dir" about 10 lines from the bottom.

How can we fix?  I looked at the agents folder and files, and nothing seems to have changed. What would have caused this?

Thanks,
-Hank
0
 
LVL 20

Expert Comment

by:Ejgil Hedegaard
Comment Utility
Probably you have an agent folder with no file.

The check for "no more files to use in agent folder" is done after the code has run once.
This changes it to check before the first run (for each agent).

Change 2 lines.
1. Look for (about 10 lines after the comment 'Copy pictures from agent file)
        FilenameAgent = Dir(PathAgentFile + "*.xlsx")
        Do
Change the second line with Do to
Do While FilenameAgent <> ""

2. Just below the line with the error.
Remove Until FilenameAgent = "" in the statement
Loop Until FilenameAgent = ""
so it is only Loop
0
 

Author Comment

by:Hank11
Comment Utility
Its fixed now.  I started looking at the agents files and noticed one of the agents "saved-as" to older type  *.xls instead of *.xlsx for newer files. I corrected and the picture mapping started working again.

Thank you again, Ejgil.
0
 

Author Comment

by:Hank11
Comment Utility
Hi Ejgil,

One more question.

The auto row height stopped working and I'm not sure why.  No errors messages. When I execute it runs through the process (slowly) completes, no errors and none of the rows adjust. I'm a little stumped on this.

Thanks,
-Hank
0
 
LVL 20

Expert Comment

by:Ejgil Hedegaard
Comment Utility
Without more information it is impossible to tell why adjustment does not work now.
It worked before, so clearly something has been changed.
The function loops all rows from 1 to the last used row, looks for the word Status in column B, and adjust the merged cells in column C for that row.

To see the process, set a ' in front of the line
Application.ScreenUpdating = False
The ' makes it a comment doing nothing, and the line turns green.
and insert
Range("B" & rw).Select
just after the line
If Range("B" & rw) = "Status" Then

You should see the cells unmerge, column C expand width, adjust row height and merge the cells again.  
It will be quite slow, so save the workbook before the changes, so you can stop the code (Ctrl+Break) and quit the workbook without save if needed.

The speed could depend on the calculation.
Are other workbooks open?
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
XMind Plus helps organize all details/aspects of any project from large to small in an orderly and concise manner. If you are working on a complex project, use this micro tutorial to show you how to make a basic flow chart. The software is free when…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now