I have an excel file which contains 1000+ pictures. The pictures are embeded in Column J of each row.
I have a userform which allows user to update a picture. What I want is to delete the picture that is present in the cell before updating a new picture.
The code that I found and tried to use:
Dim curPic As Shape
For Each curPic In Worksheets("Sheet1").Shapes
If Not Application.Intersect(curPic.TopLeftCell, PicCell) Is Nothing Then
curPic.Delete
End If
Next curPic
The thing is since I have a 1000+ pic, it checks each and every picture and I get a "Not Responding" on the file.
Is there a way to search only in a particular cell since I know the cell location.
Assumption: the top left corner of the shape is within the particular cell.
This routine takes the cell you want to check - and then compares the topLeftCell-Address of each shape against the address of your cell.
If they match, shape will be deleted.
What is different to your code: I am comparing the addresses of the ranges and am not intersecting ranges. I suppose this will be faster but haven't tested it.
Furthermore the for-next-loop is exited as soon as the shape has been found. That means the routine will be faster for the first cells in your column but slower for the last cells.
Option Explicit
Sub deleteShapeInRange(rgCell As Range)
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = rgCell.Address Then
shp.Delete
exit for
End If
Next
End Sub
Related
I am having issues with writing a code in macro that will select multiple cells given those I've selected with Ctrl+ Click.
What I mean by this is, when I use Ctrl+ Click to select multiple cells, I want a macro to then select those cells plus the 5 cells to the right. However, I'm unsure what the code would be for Excel to know what cells I've selected from Ctrl+ Click.
Any suggestions/help would be greatly appreciated.
I think you would need to loop through the areas of the current selection to resize the selection if you selected multiple not continuous cells:
Option Explicit
Public Sub SelectPlusFiveColumns()
Dim FinalRange As Range
Dim Area As Range
For Each Area In Selection.Areas 'loop through areas
If FinalRange Is Nothing Then
Set FinalRange = Area.Resize(ColumnSize:=6)
Else
Set FinalRange = Union(FinalRange, Area.Resize(ColumnSize:=6)) 'resize each area and collect all areas in FinalRange
End If
Next Area
FinalRange.Select 'select all resized areas
End Sub
Note: Selection of overlapping areas will be combined to one area.
I am new to VBA, and I have a sheet which has VBA macros assigned to shapes. It works fine on the same sheet, but when I copy and paste the shapes in the next sheet or create a new shape and assign the same macro it does not work. Kindly help me. Below is the code.
ActiveSheet.Shapes("CTSnext").Fill.ForeColor.SchemeColor = Black
Thanks for your response !!
However, Let me explain the issue.
In Sheet 1 I have 4 shapes Named
1) Cancelling the service
2) Next
3) Not interested
4) Reset
And all 3 shapes (2,3,4) will be in forecolor as white so it will be invisible.
When user clicks on "Cancelling the service" "Next" will appear (Meaning the fore color will change to black). And when "Next" is clicked "Not interested" will appear (Meaning the fore color will change to black). And when user clicks on "Reset" both "Next" & "Not interested" will turn into invisible (Meaning the fore color will change to white). Until now everything works fine.
Now i want to have a shape in Sheet 2 which says "Reset". So when user clicks on it the same function (Meaning the VBA of the "Reset" button in Sheet 1) should happen.
Below are the code.
For Cancel
ActiveSheet.Shapes("Next").Fill.ForeColor.SchemeColor = Black
For Next
ActiveSheet.Shapes("Notinterested").Fill.ForeColor.SchemeColor = Black
For Reset
ActiveSheet.Shapes("Next").Fill.ForeColor.SchemeColor = 1
ActiveSheet.Shapes("Notinterested").Fill.ForeColor.SchemeColor = 1
I hope i made myself clear, also i don't know to how to attach the excel file to this page so it will be helpful for you all to understand my need.
Thanks is advance.
Your line of code refers to one specific named shape (CTSnext). You replace that by shape number if you have only one in the sheet Shapes(0).
If you have several shapes on the current sheet and you want the macro to run on all shape, you can use a loop like
for each shp in ActiveSheet.Shapes
shp.Fill.ForeColor.SchemeColor = Black
Next shp
Following on from iDevlop's answer to loop through each Worksheet as well as each shape.
Dim wks as Worksheet
For Each wks in Me.Worksheets
For Each shp in wks.Shapes
shp.Fill.ForeColor.SchemeColor = Black
Next shp
Next wks
I have made a large diagram of made by shapes with numbers stored inside as text and need to change the "old" numbers to a "new" range of numbers. On each of the 20 sheets there are circles, Rectangles, Left Arrows and Right Arrows. The old range of numbers are stored on a separate spreadsheet in the Column "A" and need to be changed to the numbers listed in Column "B" (as in A1 to B1).
What would a VBA method to change the old text inside the Shapes to the new correct text based off of a new range of numbers? Is it possible to write a script that changes the values in the entire WorkBook?
My incorrect way of thinking is to:
1. Search inside the diagram to find the various shapes.
2. Get the text inside each shape.
3. Compare the text with the spreadsheet with the old numbers.
4. Insert the new number.
5. Move onto the next shape.
Put a value in A1 and say we already have a Shape:
Running this:
Sub LinkCellToShape()
Dim sh As Shape
Set sh = ActiveSheet.Shapes(1)
sh.DrawingObject.Formula = "=A1"
End Sub
will link the text in the shape to the value in the cell. You could also use:
sh.OLEFormat.Object.formula = "=A1"
I have a SAP Report embedded in a worksheet, it is refreshed via a macro using variables defined in another worksheet. That all works fine, but i am having trouble selecting the data the report generates.
The headings of the report are in and always will fall in this range ("A17:K17"), but the results rows will vary making the total range I want to capture anywhere from ("A17:K18") to (A17:K1000").
The solutions I've already tried didn't work i think because there is almost no consistency in the result data, it's a mixture of text and numbers with empty cells all over the place, in both the rows and columns. Including the occasional completely empty row. This means the methods I have tried before reach a point where it thinks it's reached the end of the populated rows - but it hasn't.
The only factor that remains the same throughout the report is that the cells in the range I want to capture are all filled with a color as default and anything outside the range is unfilled.
To me the simplest solution would be to use VBA to select all the cells beneath and including the headers on ("A17:K17") where the color index is not 0 (blank?) regardless of their contents as I don't mind capturing empty cells. Except I don't know how to do this.
At this point I'd just like to select this range I haven't decided if I'm going to copy it into a new workbook or into an email yet, but that I can do. I've just hit a dead end selecting it.
Quite unsure exactly what it is you require but here's a solution. It's worth noting that both the ColorIndex and Color properties are not necessarily zero with no fill, so if you just change blankCell to a cell with the fill which you define to be blank you'll be good to go.
Sub test()
Set blankCell = Range("A1") ' change this to a cell that you define to be blank
blankIndex = blankCell.Interior.Color
Set cellsDesired = Range("A17:K17")
For Each cell In Range("A17:K1000")
If cell.Interior.Color <> blankIndex Then
Set cellsDesired = Application.Union(cellsDesired, Range(cell.Address))
End If
Next cell
cellsDesired.Select
End Sub
I'm automatically generating a powerpoint slide through VBA, User Forms, and Excel. You run the VBA script in excel, fill out the data, the data goes into cells in excel, then the VBA script pulls the data and puts it into textbox shapes in the slide.
My problem is I want to use different font sizes at different times, so for example 28 pt font for one part and 14 pt for the rest. The problem is that any property changes I make to the textbox applies to all of the text within the shape.
My current workaround is sloppy and is to just generate another textbox over the original and insert spacing in the original so it looks like the larger text is "in" the textbox while it's actually just sitting over a few empty lines set aside.
You can format specific substrings within a string, but it's very cumbersome, for example assuming shp is an object variable representing your textbox:
Sub foo()
Dim shp As Shape
Set shp = ActivePresentation.Slides(1).Shapes("TextBox 3")
shp.TextFrame.TextRange.Text = "Hello, world!"
shp.TextFrame.TextRange.Characters.Font.Size = 14 'applies uniform font to entire shape
shp.TextFrame.TextRange.Characters(1, 5).Characters.Font.Size = 28
End Sub
Example output:
The difficulty of course is working with mixed formats, and I do not think there is any easy solution. It will be up to you to determine what formats you need to "capture", and what subsequently implement the appropriate conditional logic to transfer those formats to the PowerPoint shapes.
One possible alternative -- and this is the route that I would go if I were you -- would be to copy the cell from Excel, and use this method to paste in to PowerPoint. I believe this will create a table consisting of a single cell, in the PowerPoint slide. You will have to make adjustments for size/position, but this should be an order of magnitude easier than trying to capture every possible variation of font formatting:
Sub foo2()
Dim shp As Shape
Dim xl As Object
'Get Excel and copy a specific cell
Set xl = GetObject(, "Excel.Application")
xl.Workbooks("Book35").Sheets("Sheet2").Range("B4").Copy
'Paste that cell in to PowerPoint as a table, preserving formats:
ActivePresentation.Slides(1).Select
Application.CommandBars.ExecuteMso "PasteSourceFormatting"
End Sub
Example output, as copied from the Excel cell:
No need to change the font in excel to reflect in Word. You can do it directly. Just paste the below mentinoed line in Word VBA : -
Activedocument.Shapes("sam").TextFrame.TextRange.Words(1).Font.Size = 28