Home » excel » Is there any way I can condense this code in VBA excel? Maybe using a loop or function

Is there any way I can condense this code in VBA excel? Maybe using a loop or function

Posted by: admin May 14, 2020 Leave a comment

Questions:

I wrote this code to find the row of a word, and take a column (which is the same for every word) and copy that to another column. It will make more sense if you look at the code below. This code works if the word such as purple, blue, etc exists in the column, but if the word doesn’t then I get an error message. I have tried to use an error handler “on error resume next” and it works when I am trying to find a colour and doesn’t pick the correct number and picks a random number off the excel (for example, the “1” I have in the last row isn’t chosen correctly.)

This is the code I have right now. I am just looking for guidance to maybe put it into a loop or function.

Employee.Cells(.Find("Purple").Row, "D").Copy GroupWS.Range("H15")
Employee.Cells(.Find("Red").Row, "D").Copy GroupWS.Range("H16")
Employee.Cells(.Find("Green").Row, "D").Copy GroupWS.Range("H17")
Employee.Cells(.Find("Blue").Row, "D").Copy GroupWS.Range("H18")
Employee.Cells(.Find("Yellow").Row, "D").Copy GroupWS.Range("H19")
Employee.Cells(.Find("Orange").Row, "D").Copy GroupWS.Range("H20")
Employee.Cells(.Find("White").Row, "D").Copy GroupWS.Range("H21")
Employee.Cells(.Find("1").Row, "D").Copy GroupWS.Range("H21")
How to&Answers:

This would be the loop:

Option Explicit
Sub Test()

    Dim Employee As Worksheet, GroupWS As Worksheet
    Dim i As Long
    Dim arr As Variant

    arr = Array("Purple", "Red", "Green", "Blue", "Yellow", "Orange", "White", "1")
    For i = LBound(arr) To UBound(arr)
        With Employee
            .Cells(.Cells.Find(arr(i)).Row, "D").Copy GroupWS.Range("H" & 15 + i)
        End With
    Next i

End Sub

You just fill an array the items you are looking for and then loop trhough it. Note that arrays build like that start at 0, so the first i = 0.

Edit: Noticed that your last copy paste goes to the same cell as the one before, is that your intended goal?

Edit2: This would be with a reusable sub procedure:

Option Explicit
Sub Test()

    Dim Employee As Worksheet, GroupWS As Worksheet

    CopyValue "Purple", Employee, GroupWS, "H15"

End Sub
Sub CopyValue(StrCopy As String, wsOrigin As Worksheet, wsTarget As Worksheet, Cell As String)

    With wsOrigin
        .Cells(.Cells.Find(StrCopy).Row, "D").Copy wsTarget.Range(Cell)
    End With

End Sub