Solved: Is there a way of shortening my ever increasing vba

[gringo287]

Hi,

The macro below works fine, but as i wrote it myself (I pillaged the Module vba from google)... It's highly likely to be very bloated.

The aim is to show the relevant image based on the user selection. The selection list is going to end up being 60 items long though which would make this vba massive, for such a simple task.

Is there a way to reference the images in a much more condensed method



sheet code

[VBA]Sub blah3()
Application.ScreenUpdating = False
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "apple" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 2")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "blackberry" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "sony" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 4")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "nokia" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 5")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "htc" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 6")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "lg" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 7")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
Else:
Sheets("Sheet1").Range("M7").Select
Call RemoveObjectsFromSelection
If Sheets("Sheet1").Range("A1").Value = "samsung" Then
Sheets("Sheet2").Select
ActiveSheet.Shapes.Range(Array("Picture 8")).Select
Selection.Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
End If
End If
End If
End If
End If
End If
End If
End Sub[/VBA]

module

[VBA]Sub RemoveObjectsFromSelection()
Dim ole As OLEObject
Dim shp As Shape

For Each ole In Selection.Parent.OLEObjects
If Not Application.Intersect(Selection, _
ole.TopLeftCell) Is Nothing Then
ole.Delete
End If
Next ole

For Each shp In Selection.Parent.Shapes
If Not Application.Intersect(Selection, _
shp.TopLeftCell) Is Nothing Then
shp.Delete
End If
Next shp
End Sub[/VBA]

[Bob Phillips]

[VBA]Sub blah3()
Application.ScreenUpdating = False

Call RemoveObjectsFromSelection(Sheets("Sheet1").Range("M7"))
If Sheets("Sheet1").Range("A1").Value = "apple" Then
Call CopyShape("Picture 2")
ElseIf Sheets("Sheet1").Range("A1").Value = "blackberry" Then
Call CopyShape("Picture 3")
ElseIf Sheets("Sheet1").Range("A1").Value = "sony" Then
Call CopyShape("Picture 4")
ElseIf Sheets("Sheet1").Range("A1").Value = "nokia" Then
Call CopyShape("Picture 5")
ElseIf Sheets("Sheet1").Range("A1").Value = "htc" Then
Call CopyShape("Picture 6")
ElseIf Sheets("Sheet1").Range("A1").Value = "lg" Then
Call CopyShape("Picture 7")
ElseIf Sheets("Sheet1").Range("A1").Value = "samsung" Then
Call CopyShape("Picture 8")
End If
End Sub

Sub RemoveObjectsFromSelection(ByRef rng As Range)
Dim ole As OLEObject
Dim shp As Shape

For Each ole In rng.Parent.OLEObjects
If Not Application.Intersect(Selection, _
ole.TopLeftCell) Is Nothing Then
ole.Delete
End If
Next ole

For Each shp In rng.Parent.Shapes
If Not Application.Intersect(Selection, _
shp.TopLeftCell) Is Nothing Then
shp.Delete
End If
Next shp
End Sub

Private Function CopyShape(ShapeName As String)
Sheets("Sheet2").Shapes(ShapeName).Copy
Sheets("Sheet1").Select
Range("M7").Select
ActiveSheet.Paste
End Function
[/VBA]

[Bob Phillips]

Alternatively

[VBA]Sub blah3()
Application.ScreenUpdating = False

Call RemoveObjectsFromSelection(Sheets("Sheet1").Range("M7"))
Select Case Sheets("Sheet1").Range("A1").Value
Case "apple": Call CopyShape("Picture 2")
Case "blackberry": Call CopyShape("Picture 3")
Case "sony": Call CopyShape("Picture 4")
Case "nokia": Call CopyShape("Picture 5")
Case "htc": Call CopyShape("Picture 6")
Case "lg": Call CopyShape("Picture 7")
Case "samsung": Call CopyShape("Picture 8")
End Select
End Sub[/VBA]

[p45cal]

Sacrificing readability, maintainability and ditching the copyshape function, using xld's version of RemoveObjectsFromSelection you could reduce blah3 to 3 lines assuming the user always selects a valid choice (as in a data validation list perhaps):
[VBA]Sub blah4()
RemoveObjectsFromSelection Sheets("Sheet1").Range("M7")
Sheets("Sheet2").Shapes("Picture " & Application.Match(Sheets("Sheet2").Range("A1").Value, Array("apple", "blackberry", "sony", "nokia", "htc", "lg", "samsung"), 0) + 1).Copy
Sheets("Sheet1").Paste Range("M7")
End Sub
[/VBA]

[gringo287]

Excel is freakin awesome!

Thanks guys, I'll have a propper look at these tonight.

you could reduce blah3 to 3 lines assuming the user always selects a valid choice (as in a data validation list perhaps):

The cell that it will be working off will always show the exact result as its populated by another macro that picks out key words from the search box that this project is designed around.

[snb]

Since designing precedes coding, you'd better rename the shapes in accordance to the possible values in cell A1.
At the same time you can store the name of the chosen picture 'in' cell M7

After having done so the only code you need is:

[vba]Sub M_snb()
with Sheets("Sheet1")
.shapes(.Range("M7").value).delete
Sheets("Sheet2").Shapes(Sheets("Sheet2").Range("A1").Value).Copy
.Paste Range("M7")
end with
End Sub[/vba]

[gringo287]

Thanks Snb, this is just a bodge up example, just to test it out before i impliment it in the project, so the picture names arent too important at this stage.

regarding :

At the same time you can store the name of the picture 'in' cell M7

I'm not quite following you

[snb]

As you can see in the code I suggested, you don't have to loop all shapes before manipulating one. You can address it directly using it's name, provided you have systematically given them names and provided you have stored the name of a picture you want to refer to.

The code I suggested does the same thing as all the code you posted in #1 together.

[gringo287]

Hi,

Sorry to be a pest.

I wouldn't normally persist with this and take up more of your time, especially as this is just a vba shrinking exercise, however, as I'm having some weird issues since getting my new pc and having office 2013 and as im cant get any of you kind gents suggestions to work.. i thought I'd post a test file so you can either point out my glaring mistake or maybe it being an issue linked to the other issues im trying to sort out.

for everyone's suggestions apart from snb's i'm getting ""compile error
wrong number of arguments or invalid property assignment
""
and for snb's im getting ""system error &H80070057 (-2147024809) the parameter is incorrect""

[p45cal]

1. You haven't renamed the pictures. (for snb's and xld's (modified by you) solution.
2. You haven't used xld's version of RemoveObjectsFromSelection (for mine and xld's solutions.
3. xld's RemoveObjectsFromSelection needs a change:[vba]Sub RemoveObjectsFromSelection(ByRef rng As Range)
Dim ole As OLEObject
Dim shp As Shape

For Each ole In rng.Parent.OLEObjects
If Not Application.Intersect(rng, _
ole.TopLeftCell) Is Nothing Then
ole.Delete
End If
Next ole

For Each shp In rng.Parent.Shapes
If Not Application.Intersect(rng, _
shp.TopLeftCell) Is Nothing Then
shp.Delete
End If
Next shp
End Sub
[/vba] 4. One alteration to mine in the following line:[vba]Sheets("Sheet2").Shapes("Picture " & Application.Match(Sheets("Sheet1").Range("A1").Value, Array("apple", "blackberry", "sony", "nokia", "htc", "lg", "samsung"), 0) + 1).Copy
[/vba]
The attached has had these amendments so that mine works.

[gringo287]

well thats annoying!!. i had actually done it initially. must have forgot to save it after changing the names.

[gringo287]

Thanks P45cal, snb and xld,

I've not had time today to set it up in my actual workbook, but as my silly mistakes have been pointed out, i have no doubt that they will work as P45cal's attachment works fine.

Yet again, this has been an excellant example of how helpful all you guys are, so thank you very much.

[snb]

This is all you need after renameing the pictures in sheet2:

[vba]
Sub M_snb()
With Sheets("Sheet1")
.Shapes(.Shapes.Count).Delete
Sheets("Sheet2").Shapes(.Range("A1").Value).CopyPicture
.Paste Range("c9")
End With
End Sub
[/vba]

[gringo287]

ok, now I'm really pushing my luck, but....


Snb, I'm having issues with your suggestion. It works fine,but, only if there is an image in ("C9") to begin with. Which i can obviously get around if i just add an image there, however, for some reason, the image keeps getting deleted and therefore i have to add an image manually again before it will start working again.

This is all you need after renaming the pictures in sheet2:

[VBA]Sub M_snb()
With Sheets("Sheet1")
.Shapes(.Shapes.Count).Delete
Sheets("Sheet2").Shapes(.Range("A1").Value).CopyPicture
.Paste Range("c9")
End With
End Sub [/VBA]

[snb]

[vba]Sub M_snb()
With Sheets("Sheet1")
if .shapes.count> .oleobjects.count then .Shapes(.Shapes.Count).Delete
Sheets("Sheet2").Shapes(.Range("A1").Value).CopyPicture

.Paste Range("c9")

End With

End Sub[/vba]

or if you are using formcontrols:

[vba]

Sub M_snb()
With Sheets("Sheet1")
If .Shapes.Count > .Buttons.Count Then .Shapes(.Shapes.Count).Delete
Sheets("Sheet2").Shapes(.Range("A1").Value).Copy
.Paste Range("c9")
End With
End Sub

[/vba]