I'm working on a macro which copies some pictures to a new sheet, then resizes the pictures. The user can input a number 1, 2, ..., 5 and, depending on the number, the macro returns a different set of pictures. I've managed to get a working macro (copied below) but there is a lot of repetition, the macro essentially boils down to a big If statement:

If obj_n = 1 Then [code to get pictures] ElseIf obj_n = 2 Then [code to get pictures] ...

The [code to get pictures] part is very similar in each case, the only difference being

  • The names of the pictures
  • The colors of the text

Is there a way to store the [code to get pictures] in another macro, and then call that macro for each part of the If statement?

Here's the full code:

Option Explicit

Sub PopulateResources()
  ' Creates a version of the resources sheet with the relevant tables

  Application.ScreenUpdating = False

  Dim pic As Object
  Dim obj_n As Integer

  With ThisWorkbook.Sheets("Resources")
    ' Clear any pictures already on the page
    For Each pic In ActiveSheet.Pictures
    Next pic

    On Error GoTo Ender
    obj_n = .Range("Y5")

    If obj_n = 1 Then
      ' Get the pictures
      ThisWorkbook.Sheets("List Objectives").[kwa_1].Copy
      .Range("B15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[obj_desc1].Copy
      .Range("B5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[im_1].Copy
      .Range("S5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kdp_1].Copy
      .Range("N15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kr_1].Copy
      .Range("N29").PasteSpecial xlPasteValues
      ' Set text colours
      .Range("B13").Font.Color = 12611584
      .Range("N13").Font.Color = 12611584
      .Range("N27").Font.Color = 12611584
      .Range("B36").Font.Color = 12611584
    ElseIf obj_n = 2 Then
      ' Get the pictures
      ThisWorkbook.Sheets("List Objectives").[kwa_2].Copy
      .Range("B15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[obj_desc2].Copy
      .Range("B5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[im_2].Copy
      .Range("S5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kdp_2].Copy
      .Range("N15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kr_2].Copy
      .Range("N29").PasteSpecial xlPasteValues
      ' Set the text colours
      .Range("B13").Font.Color = 4626167
      .Range("N13").Font.Color = 4626167
      .Range("N27").Font.Color = 4626167
      .Range("B36").Font.Color = 4626167
    ElseIf obj_n = 3 Then
      ' Get the pictures
      ThisWorkbook.Sheets("List Objectives").[kwa_3].Copy
      .Range("B15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[obj_desc3].Copy
      .Range("B5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[im_3].Copy
      .Range("S5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kdp_3].Copy
      .Range("N15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kr_3].Copy
      .Range("N29").PasteSpecial xlPasteValues
      ' Set the text colours
      .Range("B13").Font.Color = 192
      .Range("N13").Font.Color = 192
      .Range("N27").Font.Color = 192
      .Range("B36").Font.Color = 192
    ElseIf obj_n = 4 Then
      ' Get the pictures
      ThisWorkbook.Sheets("List Objectives").[kwa_4].Copy
      .Range("B15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[obj_desc4].Copy
      .Range("B5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[im_4].Copy
      .Range("S5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kdp_4].Copy
      .Range("N15").PasteSpecial xlPasteValues
      ' Set the text colours
      .Range("B13").Font.Color = 10498160
      .Range("N13").Font.Color = 10498160
      .Range("N27").Font.Color = 10498160
      .Range("B36").Font.Color = 10498160
    ElseIf obj_n = 5 Then
      ' Get the pictures
      ThisWorkbook.Sheets("List Objectives").[kwa_5].Copy
      .Range("B15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[obj_desc5].Copy
      .Range("B5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[im_5].Copy
      .Range("S5").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kdp_5].Copy
      .Range("N15").PasteSpecial xlPasteValues
      ThisWorkbook.Sheets("List Objectives").[kr_5].Copy
      .Range("N29").PasteSpecial xlPasteValues
      ' Set the colours
      .Range("B13").Font.Color = 5287936
      .Range("N13").Font.Color = 5287936
      .Range("N27").Font.Color = 5287936
      .Range("B36").Font.Color = 5287936
      GoTo Ender
    End If

    ' Resize the pictures
    With ActiveSheet.Pictures(1)
      .Height = 312
      .Width = 511
    End With
    With ActiveSheet.Pictures(2)
      .Height = 112
      .Width = 759
    End With
    With ActiveSheet.Pictures(3)
      .Height = 87
      .Width = 106
    End With
  End With
  Application.ScreenUpdating = True
End Sub
  • \$\begingroup\$ The first idea would be to wrap the repeated code in a function (or rather sub as you dont need a return value), with source/destination ranges as parameters \$\endgroup\$ – Stefan Sep 24 '17 at 12:03
  • \$\begingroup\$ A lookup table (array) for kwa_1 etc. would also remove the need for the if's \$\endgroup\$ – Stefan Sep 24 '17 at 12:10

Main changes I made when refactoring:

  • Moved all hard-codded values to the top (constants) where they can be updated easier
    • all constants are strings holding separate values for each set
    • these string are split and used as arrays in For loops
    • naming convention for images is not very descriptive but it's consistent (setID at end)
  • Replaced the For loop used to delete all images with Worksheet.Pictures.Delete
  • Added the Sleep API to force the paste operation to wait - this was causing the errors
    • on my machine waiting 0.7 seconds was long enough, but I made it 0.9 seconds
  • All ranges are updated at once (using Join())

Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As LongPtr)
    Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds as Long)
#End If

Public Sub PopulateResources()
    Const DELIM = " "
    Const DELIM_RNG = ","
    Const PIC_SET   As String = "kwa_ obj_desc im_ kdp_ kr_"
    Const COPY_RNG  As String = "B15 B5 S5 N15 N29"
    Const FONT_RNG  As String = "B13 N13 N27 B36"
    Const SET_CLR   As String = "12611584 4626167 192 10498160 5287936"
    Const SET_SIZE = "312 511 112 759 87 106"   'holds pairs of Height and Width

    Dim wsRes As Worksheet, wsObj As Worksheet, cellID As Range, setID As Long
    Set wsRes = ThisWorkbook.Worksheets("Resources")
    Set wsObj = ThisWorkbook.Worksheets("List Objectives")
    Set cellID = wsRes.Range("Y5")
    setID = IIf(Not IsError(cellID), IIf(Len(cellID) > 0, Abs(cellID.Value2), 1), 1)

    wsRes.Pictures.Delete           'remove all pix

Application.ScreenUpdating = False

    Dim picSet As Variant, cpyRng As Variant, setClr As Variant, fntRng As Variant

    picSet = Split(PIC_SET, DELIM)
    cpyRng = Split(COPY_RNG, DELIM)
    setClr = Split(SET_CLR, DELIM)
    fntRng = Split(FONT_RNG, DELIM)

    Dim i As Long, ub As Long       'all sets are 5 pix (ub), except set4: 4 pix
    ub = UBound(picSet):    If setID = 4 Then ub = ub - 1

    For i = LBound(picSet) To UBound(picSet)
        wsObj.Shapes(picSet(i) & setID).Copy
        Sleep 0.9   'Application.Wait Now + #12:00:01 AM#
        wsRes.Range(cpyRng(i)).PasteSpecial xlPasteValues
        If i = 1 Then wsRes.Range(Join(fntRng, DELIM_RNG)).Value2 = setClr(i)
        If i < 5 Then wsRes.Range(Join(fntRng, DELIM_RNG)).Font.Color = setClr(i)

    Dim setSize As Variant, j As Long
    setSize = Split(SET_SIZE, DELIM)
    j = 0
    For i = 1 To 3
        With wsRes.Pictures(i)
          .Height = setSize(j)
          .Width = setSize(j + 1)
          j = j + 2
        End With
Application.ScreenUpdating = True
End Sub

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.