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

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
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

S
  • Question
VBA help
Replies
1
Views
162
Micron
M
M
  • Question
Please help me to correct Excel VBA code!
Replies
1
Views
259
Minh Tuan VN
M
L
  • Question
Compile Error when Adding Attachments
Replies
5
Views
162
6StringJazzer
6StringJazzer
O
  • Question
Creating workbooks for a team of staff
Replies
1
Views
146
HighAndWilder
H
D
  • Question
why show the frame of userform as the photo1
Replies
0
Views
173
david2005wang
D

Forum statistics

Threads
1,222,069
Messages
6,163,733
Members
451,854
Latest member
Tiffany Smith

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