Use Vlookup to add values to selected cells

[namy77]

Good morning,

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

[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]

 

[JackDanIce]

Untested, this only allows values in Sheet 2 to be entered into the input box, try:

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

 

[Fluff]

If you only have 3 values you could do something like this

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