Simplify VBA-code

R

roelandwatteeuw

Board Regular
Joined
Feb 20, 2015
Messages
87
Office Version
  1. 365
Platform
  1. Windows
Hi all

I have this part in my code, it works, but I'm pretty sure it can be written in less lines.
And I can't figure out how exacly.

Who can help me with this?

Background info:
This macro shows an InputBox where the user has to choose one of the GemOptions.
The GemOptions are stored in sheet "Admin".
If only 10 GemOptioned are filled in in the sheet "Admin", the InputBox only shows this 10 options.
The user makes his choice by entering the corresponding number (1 to 29) of the GemOption (s)he likes.


VBA Code: 
Dim Gem1 As String
Dim Gem2 As String
Dim Gem3 As String
Dim Gem4 As String
Dim Gem5 As String
Dim Gem6 As String
Dim Gem7 As String
Dim Gem8 As String
Dim Gem9 As String
Dim Gem10 As String
Dim Gem11 As String
Dim Gem12 As String
Dim Gem13 As String
Dim Gem14 As String
Dim Gem15 As String
Dim Gem16 As String
Dim Gem17 As String
Dim Gem18 As String
Dim Gem19 As String
Dim Gem20 As String
Dim Gem21 As String
Dim Gem22 As String
Dim Gem23 As String
Dim Gem24 As String
Dim Gem25 As String
Dim Gem26 As String
Dim Gem27 As String
Dim Gem28 As String
Dim Gem29 As String

GemOption:
If Sheets("Admin").Range("B41") = "" Then Gem1 = "" Else Gem1 = "1 = " & Sheets("Admin").Range("B41") & vbCrLf
If Sheets("Admin").Range("B42") = "" Then Gem2 = "" Else Gem2 = "2 = " & Sheets("Admin").Range("B42") & vbCrLf
If Sheets("Admin").Range("B43") = "" Then Gem3 = "" Else Gem3 = "3 = " & Sheets("Admin").Range("B43") & vbCrLf
If Sheets("Admin").Range("B44") = "" Then Gem4 = "" Else Gem4 = "4 = " & Sheets("Admin").Range("B44") & vbCrLf
If Sheets("Admin").Range("B45") = "" Then Gem5 = "" Else Gem5 = "5 = " & Sheets("Admin").Range("B45") & vbCrLf
If Sheets("Admin").Range("B46") = "" Then Gem6 = "" Else Gem6 = "6 = " & Sheets("Admin").Range("B46") & vbCrLf
If Sheets("Admin").Range("B47") = "" Then Gem7 = "" Else Gem7 = "7 = " & Sheets("Admin").Range("B47") & vbCrLf
If Sheets("Admin").Range("B48") = "" Then Gem8 = "" Else Gem8 = "8 = " & Sheets("Admin").Range("B48") & vbCrLf
If Sheets("Admin").Range("B49") = "" Then Gem9 = "" Else Gem9 = "9 = " & Sheets("Admin").Range("B49") & vbCrLf
If Sheets("Admin").Range("B50") = "" Then Gem10 = "" Else Gem10 = "10 = " & Sheets("Admin").Range("B50") & vbCrLf
If Sheets("Admin").Range("B51") = "" Then Gem11 = "" Else Gem11 = "11 = " & Sheets("Admin").Range("B51") & vbCrLf
If Sheets("Admin").Range("B52") = "" Then Gem12 = "" Else Gem12 = "12 = " & Sheets("Admin").Range("B52") & vbCrLf
If Sheets("Admin").Range("B53") = "" Then Gem13 = "" Else Gem13 = "13 = " & Sheets("Admin").Range("B53") & vbCrLf
If Sheets("Admin").Range("B54") = "" Then Gem14 = "" Else Gem14 = "14 = " & Sheets("Admin").Range("B54") & vbCrLf
If Sheets("Admin").Range("B55") = "" Then Gem15 = "" Else Gem15 = "15 = " & Sheets("Admin").Range("B55") & vbCrLf
If Sheets("Admin").Range("B56") = "" Then Gem16 = "" Else Gem16 = "16 = " & Sheets("Admin").Range("B56") & vbCrLf
If Sheets("Admin").Range("B57") = "" Then Gem17 = "" Else Gem17 = "17 = " & Sheets("Admin").Range("B57") & vbCrLf
If Sheets("Admin").Range("B58") = "" Then Gem18 = "" Else Gem18 = "18 = " & Sheets("Admin").Range("B58") & vbCrLf
If Sheets("Admin").Range("B59") = "" Then Gem19 = "" Else Gem19 = "19 = " & Sheets("Admin").Range("B59") & vbCrLf
If Sheets("Admin").Range("B60") = "" Then Gem20 = "" Else Gem20 = "20 = " & Sheets("Admin").Range("B60") & vbCrLf
If Sheets("Admin").Range("B61") = "" Then Gem21 = "" Else Gem21 = "21 = " & Sheets("Admin").Range("B61") & vbCrLf
If Sheets("Admin").Range("B62") = "" Then Gem22 = "" Else Gem22 = "22 = " & Sheets("Admin").Range("B62") & vbCrLf
If Sheets("Admin").Range("B63") = "" Then Gem23 = "" Else Gem23 = "23 = " & Sheets("Admin").Range("B63") & vbCrLf
If Sheets("Admin").Range("B64") = "" Then Gem24 = "" Else Gem24 = "24 = " & Sheets("Admin").Range("B64") & vbCrLf
If Sheets("Admin").Range("B65") = "" Then Gem25 = "" Else Gem25 = "25 = " & Sheets("Admin").Range("B65") & vbCrLf
If Sheets("Admin").Range("B66") = "" Then Gem26 = "" Else Gem26 = "26 = " & Sheets("Admin").Range("B66") & vbCrLf
If Sheets("Admin").Range("B67") = "" Then Gem27 = "" Else Gem27 = "27 = " & Sheets("Admin").Range("B67") & vbCrLf
If Sheets("Admin").Range("B68") = "" Then Gem28 = "" Else Gem28 = "28 = " & Sheets("Admin").Range("B68") & vbCrLf
If Sheets("Admin").Range("B69") = "" Then Gem29 = "" Else Gem29 = "29 = " & Sheets("Admin").Range("B69") & vbCrLf


GemChoice = InputBox(Gem1 & Gem2 & Gem3 & Gem4 & Gem5 & Gem6 & Gem7 & Gem8 & Gem9 & Gem10 & Gem11 & Gem12 & Gem13 & Gem14 & Gem15 _
                    & Gem16 & Gem17 & Gem18 & Gem19 & Gem20 & Gem21 & Gem22 & Gem23 & Gem24 & Gem25 & Gem26 & Gem27 & Gem28 & Gem29, _
                    "Choose your Gem", GemChoice)
                If GemChoice = "" Then Exit Sub

        If GemChoice = "1" And Gem1 <> "" Then
            Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B41"))
        ElseIf GemChoice = "2" And Gem2 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B42"))
        ElseIf GemChoice = "3" And Gem3 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B43"))
        ElseIf GemChoice = "4" And Gem4 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B44"))
        ElseIf GemChoice = "5" And Gem5 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B45"))
        ElseIf GemChoice = "6" And Gem6 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B46"))
        ElseIf GemChoice = "7" And Gem7 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B47"))
        ElseIf GemChoice = "8" And Gem8 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B48"))
        ElseIf GemChoice = "9" And Gem9 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B49"))
        ElseIf GemChoice = "10" And Gem10 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B50"))
        ElseIf GemChoice = "11" And Gem11 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B51"))
        ElseIf GemChoice = "12" And Gem12 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B52"))
        ElseIf GemChoice = "13" And Gem13 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B53"))
        ElseIf GemChoice = "14" And Gem14 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B54"))
        ElseIf GemChoice = "15" And Gem15 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B55"))
        ElseIf GemChoice = "16" And Gem16 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B56"))
        ElseIf GemChoice = "17" And Gem17 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B57"))
        ElseIf GemChoice = "18" And Gem18 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B58"))
        ElseIf GemChoice = "19" And Gem19 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B59"))
        ElseIf GemChoice = "20" And Gem20 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B60"))
        ElseIf GemChoice = "21" And Gem21 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B61"))
        ElseIf GemChoice = "22" And Gem22 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B62"))
        ElseIf GemChoice = "23" And Gem23 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B63"))
        ElseIf GemChoice = "24" And Gem24 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B64"))
        ElseIf GemChoice = "25" And Gem25 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B65"))
        ElseIf GemChoice = "26" And Gem26 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B66"))
        ElseIf GemChoice = "27" And Gem27 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B67"))
        ElseIf GemChoice = "28" And Gem28 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B68"))
        ElseIf GemChoice = "29" And Gem29 <> "" Then Sheets("RBD").Range("L1").Value = UCase(Sheets("Admin").Range("B69"))
        Else
            MsgBox "Error" & vbCrLf _
                & "Incorrect value. Try again!", vbOKOnly, "Review Required!"
            GoTo GemOption
        End If
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try this code which loads all the data into a single array.:
VBA Code: 
Sub test()

' load all the gem choices
gemarray = Sheets("Admin").Range("B41:B69")

' concatenate them
allgems = ""
For i = 1 To 29
allgems = allgems & gemarray(i, 1) & vbCrLf
Next i
GemOption:
gemchoice = InputBox(allgems, "Choose your Gem", gemchoice)
If gemchoice = "" Then Exit Sub
If IsNumeric(gemchoice) Then
Sheets("RBD").Range("L1").Value = UCase(gemarray(gemchoice, 1))
Else
 MsgBox "Error" & vbCrLf _
                & "Incorrect value. Try again!", vbOKOnly, "Review Required!"
  GoTo GemOption
End If

End Sub
 
Upvote 0
Hi,
not fully tested but try following
Code should load cells in range with value in to an array & only allow user to enter a matching value in the inputbox

VBA Code: 
Sub GetGemOption()
    Dim Gem         As String
    Dim Response    As Variant, GemChoices() As Variant
    Dim i           As Integer, r As Integer
    
    ReDim GemChoices(1 To 29)
    
    With Worksheets("Admin")
        For r = 1 To 29
            With .Cells(40 + r, 2)
                If Len(.Value) > 0 Then
                    i = i + 1
                    Gem = Gem & r & " = " & .Value & vbCrLf
                    GemChoices(i) = r
                End If
            End With
        Next r
        
        ReDim Preserve GemChoices(1 To i)
        
        Do
            Response = InputBox(Gem & Chr(10) & "Choose your Gem", "Enter Choice")
            'cancel pressed
            If StrPtr(Response) = 0 Then Exit Sub
        Loop Until Not IsError(Application.Match(Val(Response), GemChoices, 0))
        
        Worksheets("RDB").Range("L1").Value = UCase(.Cells(40 + Val(Response), 2))
        
    End With
End Sub

Dave
 
Upvote 0
Solution
Thanks offthelip and dmt32 for the help


offthelip,
Your option looks quite good but misses the numbers I want in front of the Gems.

dmt32 - Dave,
Your option works perfect!
Hooray!


Thank you both for your time!
 
Upvote 0
Glad we were able to help

many thanks for feedback

Dave
 
Upvote 0
One more addition, is it possible to add the 'Error Message'?
VBA Code: 
            MsgBox "Error" & vbCrLf _
                & "Incorrect value. Try again!", vbOKOnly, "Review Required!"
 
Upvote 0
roelandwatteeuw said:
One more addition, is it possible to add the 'Error Message'?
VBA Code: 
            MsgBox "Error" & vbCrLf _
                & "Incorrect value. Try again!", vbOKOnly, "Review Required!"
Click to expand...

should not need it with my solution as code only allows numeric values shown to be entered in the InputBox.

Dave
 
Upvote 0
dmt32 said:
should not need it with my solution as code only allows numeric values shown to be entered in the InputBox.

Dave
Click to expand...
That's true, my only thought was to inform the users why they can't pass the screen.
But I hope that they're really not that 'stupid' that they can't figure that out :D
 
Upvote 0
roelandwatteeuw said:
That's true, my only thought was to inform the users why they can't pass the screen.
But I hope that they're really not that 'stupid' that they can't figure that out :D
Click to expand...

try this slight modification & see if helps

VBA Code: 
Sub GetGemOption()
    Dim Gem         As String, Default As String
    Dim Response    As Variant, GemChoices() As Variant
    Dim i           As Integer, r As Integer
   
    ReDim GemChoices(1 To 29)
   
    With Worksheets("Admin")
        For r = 1 To 29
            With .Cells(40 + r, 2)
                If Len(.Value) > 0 Then
                    i = i + 1
                    Gem = Gem & r & " = " & .Value & vbCrLf
                    GemChoices(i) = r
                End If
            End With
        Next r
       
        ReDim Preserve GemChoices(1 To i)
       
        Do
            Response = InputBox(Gem & Chr(10) & "Choose your Gem", "Enter Choice", Default)
            'cancel pressed
            If StrPtr(Response) = 0 Then Exit Sub
            Default = "Invalid Entry -Please Enter Value Shown In List"
        Loop Until Not IsError(Application.Match(Val(Response), GemChoices, 0))
       
        Worksheets("RDB").Range("L1").Value = UCase(.Cells(40 + Val(Response), 2))
       
    End With
End Sub

Try entering an invalid value - You should be returned to InputBox with messaged displayed - a msgbox can be added though if this is what you really want.

Dave
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
291
kvsrinivasamurthy
K
C
  • Question Question
Combining rows 3 through 7 into row 2, one row takes a painfully long time with this code. Why?
Replies
2
Views
247
jolivanes
jolivanes
N
  • Question Question
VBA - Combining a Sub and a Function
Replies
1
Views
470
Micron
M
H
  • Question Question
Advanced Multi VBA - Creating multiple temporary files and attach them to one email on outlook
Replies
2
Views
263
Hayf13
H
X
  • Solved
Excel VBA Workbook code out of range when opened
Replies
5
Views
307
Xyphus
X

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

Share this page

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