0
\$\begingroup\$

This code searches for a lookup value (Worksheet "Price", Column B13:B31) from the table array in (Worksheet "Sheet1", Column A4:Z10000).

Can this be done in a simpler or shorter way?

Please find my code below;

   Sub Lookup1()

      Dim r, i As Long, rngLU As Range, j As Long
       Dim price, descr As String
      i = 13
      j = 14
       k = 15
       l = 16
       m = 17
       n = 18
        o = 19
       p = 20
       q = 21
        g = 22
        s = 23
        t = 24
        u = 25
        v = 26
        w = 27
        x = 28
        y = 29
        Z = 30
        h = 31

     Set rngLU = Sheet4.Range("A4:A120000")
  With Sheet1

If .Range("B" & i).Value2 > 1 Then
    r = Application.Match(.Range("B" & i).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If
.Cells(i, "C") = descr
.Cells(i, "H") = price
End With
With Sheet1

If .Range("B" & j).Value2 > 1 Then
    r = Application.Match(.Range("B" & j).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(j, "C") = descr
.Cells(j, "H") = price
 End With
 With Sheet1

If .Range("B" & k).Value2 > 1 Then
    r = Application.Match(.Range("B" & k).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(k, "C") = descr
.Cells(k, "H") = price
End With
With Sheet1

If .Range("B" & l).Value2 > 1 Then
    r = Application.Match(.Range("B" & l).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(l, "C") = descr
.Cells(l, "H") = price
End With
With Sheet1

If .Range("B" & m).Value2 > 1 Then
    r = Application.Match(.Range("B" & m).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(m, "C") = descr
.Cells(m, "H") = price
 End With
 With Sheet1

If .Range("B" & n).Value2 > 1 Then
    r = Application.Match(.Range("B" & n).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(n, "C") = descr
.Cells(n, "H") = price
 End With
 With Sheet1

If .Range("B" & o).Value2 > 1 Then
    r = Application.Match(.Range("B" & o).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(o, "C") = descr
.Cells(o, "H") = price
 End With
With Sheet1

If .Range("B" & p).Value2 > 1 Then
    r = Application.Match(.Range("B" & p).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(p, "C") = descr
.Cells(p, "H") = price
 End With
 With Sheet1

If .Range("B" & q).Value2 > 1 Then
    r = Application.Match(.Range("B" & q).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(q, "C") = descr
.Cells(q, "H") = price
End With
With Sheet1

If .Range("B" & g).Value2 > 1 Then
    r = Application.Match(.Range("B" & g).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(g, "C") = descr
.Cells(g, "H") = price
  End With
With Sheet1

If .Range("B" & s).Value2 > 1 Then
    r = Application.Match(.Range("B" & s).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(s, "C") = descr
.Cells(s, "H") = price
 End With
With Sheet1

If .Range("B" & t).Value2 > 1 Then
    r = Application.Match(.Range("B" & t).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(t, "C") = descr
.Cells(t, "H") = price
 End With
 With Sheet1

If .Range("B" & u).Value2 > 1 Then
    r = Application.Match(.Range("B" & u).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(u, "C") = descr
.Cells(u, "H") = price
 End With
With Sheet1

If .Range("B" & v).Value2 > 1 Then
    r = Application.Match(.Range("B" & v).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(v, "C") = descr
.Cells(v, "H") = price
 End With
With Sheet1

If .Range("B" & w).Value2 > 1 Then
    r = Application.Match(.Range("B" & w).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(w, "C") = descr
.Cells(w, "H") = price
End With
With Sheet1

If .Range("B" & x).Value2 > 1 Then
    r = Application.Match(.Range("B" & x).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(x, "C") = descr
.Cells(x, "H") = price
 End With
With Sheet1

If .Range("B" & y).Value2 > 1 Then
    r = Application.Match(.Range("B" & y).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(y, "C") = descr
.Cells(y, "H") = price
 End With
  With Sheet1

If .Range("B" & Z).Value2 > 1 Then
    r = Application.Match(.Range("B" & Z).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(Z, "C") = descr
.Cells(Z, "H") = price
 End With
 With Sheet1

If .Range("B" & h).Value2 > 1 Then
    r = Application.Match(.Range("B" & h).Value2, rngLU, 0)
    If IsError(r) Then
        descr = "Please write manually the Item Description in Column K -->"
        price = "#N/A"
    Else
        descr = rngLU.Cells(r, 3) ' col C
        price = rngLU.Cells(r, 4) ' col D
    End If
End If

.Cells(h, "C") = descr
.Cells(h, "H") = price
  End With
 Call ClearRows
 End Sub
\$\endgroup\$
2
  • \$\begingroup\$ (As presented, the indentation of the code looks haphazard. It does not help me grasp its structure.) \$\endgroup\$
    – greybeard
    Commented Jan 6, 2022 at 7:37
  • 1
    \$\begingroup\$ I am voting not too close. At the very least this can be reviewed for naming and DRY. \$\endgroup\$
    – konijn
    Commented Jan 6, 2022 at 15:32

2 Answers 2

Reset to default
4
\$\begingroup\$

You are correct that this code can be simplified. The posted code was almost certainly created using Copy-Paste (19 times) followed by changing a single variable within the block. When code is created this way, it is always time to stop and find a way to refactor the copied code blocks to execute within some type of loop.

Fortunately in this case, the single value changed in each code block appears to be a sequence of contiguous numbers. As a result, the entire subroutine can be executed within a single For loop.

Sub Lookup1UsingLoop()
      Dim r, i As Long, rngLU As Range, j As Long
       Dim price, descr As String
        
    Set rngLU = Sheet4.Range("A4:A120000")
    Dim rangeAddress As String
    Dim rowNumber As Long
    With Sheet1
        For rowNumber = 13 To 31
            rangeAddress = "B" & CStr(rowNumber)
            If .Range(rangeAddress).Value2 > 1 Then
                r = Application.Match(.Range(rangeAddress ).Value2, rngLU, 0)
                If IsError(r) Then
                    descr = "Please write manually the Item Description in Column K -->"
                    price = "#N/A"
                Else
                    descr = rngLU.Cells(r, 3) ' col C
                    price = rngLU.Cells(r, 4) ' col D
                End If
            End If
            .Cells(rowNumber, "C") = descr
            .Cells(rowNumber, "H") = price
        Next
    End With
    Call ClearRows
End Sub
\$\endgroup\$
1
  • \$\begingroup\$ Exactly you're right! The single value changed in each code block appears. Thanks for the answer! \$\endgroup\$
    – mij nivek
    Commented Jan 12, 2022 at 10:45
3
\$\begingroup\$

There is a lot of repetition in your code, so obviously a loop can shorten code dramatically.

Tip #1: pay attention to indentation, it is important to make the flow more clear and avoid possible logic errors.

Some suggested code, untested. This should work in regular VB.net. Not sure about VBA. Declare your list of values as an Enum like this for convenience (I called it LookupTable for lack of a better name).

Public Enum LookupTable As Integer
    i = 13
    j = 14
    k = 15
    l = 16
    m = 17
    n = 18
    o = 19
    p = 20
    q = 21
    g = 22
    s = 23
    t = 24
    u = 25
    v = 26
    w = 27
    x = 28
    y = 29
    Z = 30
    h = 31
End Enum

Then you can loop on values like this:

Dim items As Array
items = System.Enum.GetValues(GetType(LookupTable))
Dim item As String
For Each item In items
    Console.WriteLine(item)
Next

This will output values from 13 through 31. (But you could as well do a regular loop from 13 to 31 if you are not really using the letters for anything).

Then you can nest your code inside the loop like this:

    Dim items As Array
    items = System.Enum.GetValues(GetType(LookupTable))
    Dim item As String

    With Sheet1
        For Each item In items
            Console.WriteLine(item)
            
            If .Range("B" & item).Value2 > 1 Then
                r = Application.Match(.Range("B" & item).Value2, rngLU, 0)
                If IsError(r) Then
                    descr = "Please write manually the Item Description in Column K -->"
                    price = "#N/A"
                    ' Exit For
                Else
                    descr = rngLU.Cells(r, 3) ' col C
                    price = rngLU.Cells(r, 4) ' col D
                End If
            End If
            .Cells(item, "C") = descr
            .Cells(item, "H") = price
        Next
    End With

You get the idea.

I think you can call Exit For in case of error, and break out of the loop. It's probably not worth continuing code execution.

You could also use UsedRange rather than specifying an overly broad selection (Sheet4.Range("A4:A120000")) and scan ranges for nothing. Performance counts. Don't scan more than necessary.

\$\endgroup\$
1
  • 1
    \$\begingroup\$ Would not work in VBA :System.Enum.GetValues(GetType(LookupTable)) is not valid, vba enums are just an alias for Long, not real objects. You can loop over an enum with contiguous members like this using a hidden [_first] and [_last] member then for i = items.[_first] to items.[_last]. However an enum doesn't look like a good choice here since the variable names are just arbitrary alphabet letters as far as I can tell. +1 for Used Range comment though. \$\endgroup\$
    – Greedo
    Commented Jan 5, 2022 at 14:49

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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