Use Vlookup to add values to selected cells

namy77

New Member
Joined
Apr 19, 2016
Messages
29
Good morning,

I currently use a sub to add an input real number to any highlighted cells:

Code:
[COLOR=#333333]Sub AddNumberPrompt()[/COLOR]<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">Dim WS As Worksheet
Dim rngSel As Range
Dim Num As Double
Dim i As Long
Dim j As Long
Dim lRows As Long
Dim lCols As Long
Dim Arr() As Variant
Dim strPrompt As String
Set rngSel = Selection
lRows = rngSel.Rows.Count
lCols = rngSel.Columns.Count
strPrompt = "Enter number to add to selected cells"

On Error Resume Next
Num = InputBox(strPrompt, "Number to Add", 7)

If Num <> 0 Then
   If rngSel.Count = 1 Then
      rngSel = rngSel + Num
   Else
      Arr = rngSel
      For i = 1 To lRows
         For j = 1 To lCols
            Arr(i, j) = Arr(i, j) + Num
         Next j
      Next i
      rngSel.Value = Arr
   End If
End If </code>[COLOR=#333333]End Sub[/COLOR]

Now I want to rather than prompt the user to put in the number. How can I change my prompt so that the user can put in an element of a VLOOKUP table (on another sheet), and the code will add the corresponding value from the next column.
For instance, if I select Student 1 and 2 in class A, and add Extra Credits to their score, I simply need to put in "EXTRA" and their scores will be:

80+5 = 85
78+5= 83

Or if I want to give all my students in both classes bonus, I select B3:C5 and type in BONUS, everybody's score will increase by 10 points.

Thanks

Sheet 1: Score Sheet
[TABLE="width: 192"]
<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"][/TD]
[TD="width: 64"]Class A[/TD]
[TD="width: 64"]Class B[/TD]
[/TR]
[TR]
[TD]Student 1[/TD]
[TD="class: xl63, align: right"]80[/TD]
[TD="class: xl63, align: right"]78[/TD]
[/TR]
[TR]
[TD]Student 2[/TD]
[TD="class: xl63, align: right"]78[/TD]
[TD="class: xl63, align: right"]65[/TD]
[/TR]
[TR]
[TD]Student 3[/TD]
[TD="class: xl63, align: right"]98[/TD]
[TD="class: xl63, align: right"]85[/TD]
[/TR]
</tbody>[/TABLE]


Sheet 2: Ad-on Table

[TABLE="width: 128"]
<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Code[/TD]
[TD="width: 64"]Value[/TD]
[/TR]
[TR]
[TD]EXTRA[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD]LATE[/TD]
[TD="align: right"]-10[/TD]
[/TR]
[TR]
[TD]BONUS[/TD]
[TD="align: right"]10[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Untested, this only allows values in Sheet 2 to be entered into the input box, try:
Code:
Sub AddCodeSelection()

    Dim dic         As Object
    Dim strTerm     As String
    Dim strInp      As String
    Dim arr()       As Variant
    Dim x           As Long
    Dim y           As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet2")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.count, 1).End(xlUp).row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = arr(x, 2)
            strTerm = strTerm & Trim$(arr(x, 1)) & "|"
        Next x
    End With
    Erase arr
        
    strTerm = UCase$(Left$(strTerm, Len(strTerm) - 1))
    strInp = UCase(InputBox("Enter Code to adjust credits with: "))
    
    If InStr(strTerm, strInp) > 0 Then
        If Selection.count = 1 Then
            ActiveCell.Value = ActiveCell.Value + dic(strInp)
        Else
            arr = Selection.Value
            For x = LBound(arr, 1) To UBound(arr, 1)
                For y = LBound(arr, 2) To UBound(arr, 2)
                    arr(x, y) = arr(x, y) + dic(strInp)
                Next y
            Next x
            Selection.Value = arr
            Erase arr
        End If
                
    End If
        
    Set dic = Nothing
    
End Sub
 
Last edited:
Upvote 0
If you only have 3 values you could do something like this
Code:
Sub AddNumberPrompt()

    Dim rngSel As Range
    Dim AdOn As String
    Dim strPrompt As String
    Dim Cl As Range
    
    Set rngSel = Selection
    strPrompt = "Enter Extra/Bonus/Late to add to selected cells"
    
    AdOn = InputBox(strPrompt)
    Select Case LCase(AdOn)
        Case "extra"
            For Each Cl In rngSel
                Cl = Cl + 5
            Next Cl
        Case "late"
            For Each Cl In rngSel
                Cl = Cl - 5
            Next Cl
        Case "bonus"
            For Each Cl In rngSel
                Cl = Cl + 10
            Next Cl
    End Select
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,170
Members
453,021
Latest member
Justyna P

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