Can I simplify this macro?

C

crazyeyeschase

Board Regular
Joined
May 6, 2014
Messages
104
Office Version
  1. 365
Platform
  1. Windows
This is a macro that i am working on for Minecraft yeah i'm a nerdy gamer however i might be using this macro or one similar to it for quite a few other things and i have noticed it is quite long.

What is does is pretty much looks for a picture in a worksheet that has the same name as a cell value in a cell (drop down list). It them copies the image accordingly. I was wondering if their might be any way to instead of having so many if statements making the cell name like a variable i dont know and this might be as simple as i can get it but just wanted to check.

Code: 
Sub BannerWool()
Dim FC As Range
Dim BannerRng As Range
Dim CellRange As String
Dim r As Long
Dim c As Long
    r = 4
    c = 3
Dim shape As shape
    
With Sheets("Banners")
    Set FC = .Range("E4")
End With
With Sheets("Sheet1")
    Set BannerRng = .Range("C4,C6,E4,E6,G4,G6")
End With

With Sheets("Pictures").Activate
If FC.Text = "White" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Orange" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Orange Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Magenta" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Magenta Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Light Blue" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Light Blue Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Yellow" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Yellow Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Lime" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Lime Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Pink" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Pink Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Gray" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Gray Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Light Gray" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Light Gray Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Cyan" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Cyan Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Purple" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Purple Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Blue" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Blue Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Brown" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Brown Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Green" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Green Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Red" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Red Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
Else
If FC.Text = "Black" Then
For Each Cell In BannerRng
    Sheets("Pictures").Shapes.Range(Array("Black Wool")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Cells(r, c).Select
        ActiveSheet.Paste
       
          If r = 4 Then
            r = r + 2
        Else
            r = 4
            c = c + 2
        End If
Next Cell
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End With

End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Try this. It's not tested at all.

Code: 
[color=darkblue]Sub[/color] BannerWool()
    
    [color=darkblue]Dim[/color] cell    [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] strWool [color=darkblue]As[/color] [color=darkblue]String[/color]
    
    [color=darkblue]With[/color] Sheets("Banners").Range("E4")
        [color=darkblue]If[/color] .Text = "White" [color=darkblue]Then[/color] strWool = "Wool" [color=darkblue]Else[/color] strWool = .Text & " Wool"
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Sheets("Sheet1").Range("C4,C6,E4,E6,G4,G6")
    
        Sheets("Pictures").Shapes.Range(strWool).Copy Destination:=cell
        
    [color=darkblue]Next[/color] cell
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
 
Upvote 0
AlphaFrog said:
Try this. It's not tested at all.

Code: 
[COLOR=darkblue]Sub[/COLOR] BannerWool()
    
    [COLOR=darkblue]Dim[/COLOR] cell    [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] strWool [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] Sheets("Banners").Range("E4")
        [COLOR=darkblue]If[/COLOR] .Text = "White" [COLOR=darkblue]Then[/COLOR] strWool = "Wool" [COLOR=darkblue]Else[/COLOR] strWool = .Text & " Wool"
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] Sheets("Sheet1").Range("C4,C6,E4,E6,G4,G6")
    
        Sheets("Pictures").Shapes.Range(strWool).Copy Destination:=cell
        
    [COLOR=darkblue]Next[/COLOR] cell
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
Click to expand...

That didn't quite work correctly however it worked well enough that i was able to tie them both together.

Code: 
Sub BannerWool()
    
    Dim cell    As Range
    Dim strWool As String
    
    With Sheets("Banners").Range("E4")
        If .Text = "White" Then strWool = "Wool" Else strWool = .Text & " Wool"
    End With
    
    For Each cell In Sheets("Sheet1").Range("C4,C6,E4,E6,G4,G6")
    
        Sheets("Pictures").Shapes.Range(Array(strWool)).Select
        Selection.Copy
        Sheets("Sheet1").Select
        cell.Select
        ActiveSheet.Paste
        
    Next cell
    
End Sub

Yours pulled an error on the actual copying of the cells.
 
Upvote 0
You're welcome.

Code: 
[color=darkblue]Sub[/color] BannerWool()
    
    [color=darkblue]Dim[/color] cell    [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] strWool [color=darkblue]As[/color] [color=darkblue]String[/color]
    
    [color=darkblue]With[/color] Sheets("Banners").Range("E4")
        [color=darkblue]If[/color] .Text = "White" [color=darkblue]Then[/color] strWool = "Wool" [color=darkblue]Else[/color] strWool = .Text & " Wool"
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Sheets("Sheet1").Range("C4,C6,E4,E6,G4,G6")
    
        Sheets("Pictures").Shapes.Range(Array(strWool)).Copy
        cell.Paste
        
    [color=darkblue]Next[/color] cell
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
 
Upvote 0
Thank you vert much.

It doesn't seem to like the .copy command much ive tried it a few times with a few other codes and each time it pulls a "Run time error "438"
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Loop/Repeat Macro
2
Replies
11
Views
353
kvsrinivasamurthy
K
K
  • Solved
My VBA is only copying the last row of data instead of all the rows
2 3
Replies
24
Views
505
Alex Blakenburg
A
M
  • Solved
Display textbox from listbox - getting 381 error
Replies
4
Views
197
maiatanaka
M
K
  • Question
Project plan does not take working days into account when adding offset
Replies
0
Views
90
KeBr
K
T
  • Solved
List values in an array?
Replies
4
Views
153
RoryA
RoryA

Forum statistics

Threads
1,214,548
Messages
6,120,146
Members
448,948
Latest member
spamiki

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top