I am starting my first user form in Excel.
I have a ComboBox, which uses a dropdown list to select a value. Once this value is selected it uses VLOOKUP to display the rest of the data in textboxes.
Upon using my reset button on the form, or trying to take out the data in these textboxes, it gives the VLOOKUP runtime error because the data is no longer there.
What do I have to do to stop this from happening?
Private Sub ComboBox1_Change()
Dim MyTableArray As Range, MyEmpID As String
Set MyTableArray = Sheets("CompressorData").Range("A:D")
Me.txtName.Value = WorksheetFunction.VLookup(Me.ComboBox1, MyTableArray, 2, 0)
Me.TextBox3.Value = WorksheetFunction.VLookup(Me.ComboBox1, MyTableArray, 1, 0)
Me.TextBox1.Value = WorksheetFunction.VLookup(Me.ComboBox1, MyTableArray, 4, 0)
End Sub
If it's the error you're trying to avoid (and just that), then include on 'On Error' statement like so:
Sub DropDown1_Change()
Dim MyTableArray As Range, MyEmpID As String
Set MyTableArray = Range("A:D")
On Error GoTo err_trap
DropDown1.txtName.Value = WorksheetFunction.VLookup(DropDown1.ComboBox1, MyTableArray, 2, 0)
DropDown1.TextBox3.Value = WorksheetFunction.VLookup(DropDown1.ComboBox1, MyTableArray, 1, 0)
DropDown1.TextBox1.Value = WorksheetFunction.VLookup(DropDown1.ComboBox1, MyTableArray, 4, 0)
err_trap:
MsgBox ("Caught the error - delete msgbox in VB code and replace with 'Exit Sub' to avoid seeing this message box! hardy har captain")
Exit Sub
End Sub
Related
I´m creating a Userform that among other things displays the name of employee when the ID field is completed.
In TextBox1 the user enters the ID and in TextBox4 they will see their names.
The problem comes because I´m using Application.Vlookup to complete TextBox4.
I´m not sure where is the error here.
Private Sub TextBox1_Change()
Dim ws As Worksheet, rngvlook As Range
Dim val As String, result As Variant
Set rngvlook = Hoja3.Range("A:B")
val = TextBox1.Value
result = Application.VLookup(val, rngvlook, 2, False)
If IsError(result) Then
TextBox4.Value = ""
Else
TextBox4.Value = result
End If
End Sub
Bellow the error
Error '-2147352571 (80020005) on execution time
Value property can´t be set. Type mismatch
The error is in a way an "architecture" error. Take a look at this VLookups with the following input in Range("A:B"):
The following code returns probabaly something unexpected:
Sub SomeTest()
'Runs ok:
Debug.Print Application.VLookup(1, Range("A:B"), 2, False)
Debug.Print Application.VLookup("id1", Range("A:B"), 2, False)
Dim val1 As Variant: val1 = 1
Debug.Print Application.VLookup(val1, Range("A:B"), 2, False)
'Error 2042:
Debug.Print Application.VLookup("1", Range("A:B"), 2, False)
Dim val2 As String: val2 = 1
Debug.Print Application.VLookup(val2, Range("A:B"), 2, False)
End Sub
Thus, in your code, you go into the second part of the example, thus going to Error 2042. Try to "move" your code to the working sample, thus declare the val as a Variant.
I'm using a form to populate a sheet in Excel. In the form, the date-related boxes are broken up by day-month-year combo boxes, which are concatenated to populate a single cell in the sheet. My question is whether there is a way to "unconcatenate" a date in a single cell and populate each individual combo box with the appropriate information (day, month, or year). This is because I want to be able to add new information in one form, then update what already exists in the table in another form.
Code to update form based on given parameter below (focus in Bold):
Private Sub txtstudynm_Change()
Dim StudyName As String
Dim WrdString As String
Dim text_string As String
If Me.txtstudynm.Value = "" Then
MsgBox "Study Name can not be blank", vbCritical
Exit Sub
End If
StudyName = txtstudynm.Value
On Error Resume Next
Me.cmbprojman.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 2, 0)
On Error Resume Next
Me.cmbstudtyp.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 3, 0)
On Error Resume Next
Me.cmbprogtyp.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 4, 0)
On Error Resume Next
Me.cmbfundtyp.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 5, 0)
On Error Resume Next
Me.txtbudget.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 6, 0)
On Error Resume Next
Me.txtencumb.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 7, 0)
On Error Resume Next
Me.cmbpath.Value = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 8, 0)
**On Error Resume Next**
**text_string = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 9, 0).Value**
**WrdString = Split(text_string, "/")(0)**
**Me.tssdcmb1.Value = WrdString**
On Error Resume Next
Me.tssdcmb2.Value = WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 9, 0)
On Error Resume Next
Me.tssdcmb3.Value = WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 9, 0)
End Sub
Instead of all those references to the worksheet, use a Variant array:
Private Sub txtstudynm_Change()
If Me.txtstudynm.Value = "" Then
MsgBox "Study Name can not be blank", vbCritical
Exit Sub
End If
Dim StudyName As String
StudyName = txtstudynm.Value
Dim lkp As Variant
lkp = Sheets("Study Summary").Range("A3:AJ3000").Value2
Dim i As Long
For i = 1 To UBound(lkp, 1)
If lkp(i, 1) = StudyName Then
Me.cmbprojman.Value = lkp(i, 2)
Me.cmbstudtyp.Value = lkp(i, 3)
Me.cmbprogtyp.Value = lkp(i, 4)
Me.cmbfundtyp.Value = lkp(i, 5)
Me.txtbudget.Value = lkp(i, 6)
Me.txtencumb.Value = lkp(i, 7)
Me.cmbpath.Value = lkp(i, 8)
Me.tssdcmb1.Value = Day(lkp(i, 9))
Me.tssdcmb2.Value = Month(lkp(i, 9))
Me.tssdcmb3.Value = Year(lkp(i, 9))
Exit For
End If
Next i
End Sub
Try this (not sure which Combo Box you set to Day/Month/Year)...
Dim StudyDate as Date
If IsDate(text_string) Then
StudyDate = CDate(txt)
Me.tssdcmb1.Value Day(StudyDate)
Me.tssdcmb2.Value Month(StudyDate)
Me.tssdcmb3.Value Year(StudyDate)
End If
Declare text_string as a proper Date value (and this is why you don't encode a variable's data type in its name). Then the VLOOKUP will yield a Date value:
text_string = Application.WorksheetFunction.VLookup(StudyName, Sheets("Study Summary").Range("A3:AJ3000"), 9, 0).Value
If what you have is a proper Date, then you use the VBA.DateTime.Year, VBA.DateTime.Month, and VBA.DateTime.Day functions to get each part:
Me.tssdcmb1.Value = Year(text_string)
Me.MonthBox.Value = Month(text_string)
Me.DayBox.Value = Day(text_string)
Notice how meaningful, pronounceable names make the code easier to read/follow.
If what you have is really a string that looks like a date, then... you better hope that the format is consistent, and then using the VBA.Strings.Split function like you did wasn't a bad idea - just use the 3 indices you got:
Dim dateParts As Variant
dateParts = Split(text_string, "/")
Me.YearBox.Value = dateParts(0)
Me.MonthBox.Value = dateParts(1)
Me.DayBox.Value = dateParts(2)
I am trying to show prices of specific cryptocurrencies in an Excel sheet. I am extracting the JSON data from the API of CoinMarketCap - https://api.coinmarketcap.com/v1/ticker/
Ultimately, I am trying to get the price of Ripple (line 16), and then set cell B1 in my Excel sheet to display the price of ripple (line 17).
This is my script, but it is not working for some reason.
Sub test()
Dim httpObject As Object
Set httpObject = CreateObject("MSXML2.XMLHTTP")
sURL = "https://api.coinmarketcap.com/v1/ticker/"
sRequest = sURL
httpObject.Open "GET", sRequest, False
httpObject.Send
sGetResult = httpObject.ResponseText
Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)
If oJSON.Name = "Ripple" Then
B1 = oJSON("Ripple")("price_usd")
End If
End Sub
The API call is successful (I believe), but I get syntax errors etc. Hope anybody is able to help. Thanks in advance
EDIT: This is Microsoft Excel 2010
EDIT 2: It is lines 16 and 17 (respectively If oJSON.Name... and B1 = oJSON(... that poses the problem, but I have been unable to solve it/find the error as of now. See comments for Run Time Error etc.
EDIT 3: I believe I have made a mistake in lines 16 and 17 by referring to oJSON and not the item (sItem). However, even after changing this (e.g. If sItem.Name = "Ripple" Then...), it is still not working.
EDIT 4: I believe I also tagged the excel-cell in the wrong manner. Instead of simply writing B1 = ..., I am now writing Range.("B1").Value = ..., which worked in a test.
Take a look at the below example. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test48852376()
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
Dim vElement As Variant
Dim sValue As String
Dim aData()
Dim aHeader()
' Retrieve JSON string
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://api.coinmarketcap.com/v1/ticker/", False
.Send
sJSONString = .responseText
End With
' Parse JSON
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON string": Exit Sub
' Extract ripple price_usd
Do
For Each vElement In vJSON
Select Case False
Case vElement.Exists("id")
Case vElement("id") = "ripple"
Case vElement.Exists("price_usd")
Case Else
MsgBox "ripple price_usd " & vElement("price_usd")
Exit Do
End Select
Next
MsgBox "ripple price_usd not found"
Loop Until True
' Output the entire table to the worksheet
JSON.ToArray vJSON, aData, aHeader
With Sheets(1)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
The output for me as follows:
BTW, the similar approach applied in other answers.
This modification suggested by #omegastripes works here. The json object is a collection of dictionaries, so you need to treat it as such.
Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)
Dim V As Object
For Each V In oJSON
If V("name") = "Ripple" Then
Cells(1, 2) = V("price_usd")
Exit For
End If
Next V
I've written a routine that deletes checkboxes and labels which are dynamically added to a sheet. However, it doesn't realiably delete all the controls. I need to ensure they are completely removed before adding again.
Here is my routine:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim intPass As Integer, objShape As Shape
For intPass = 1 To 2
For Each objShape In ActiveSheet.Shapes
Dim strName As String
strName = objShape.Name
If Mid(strName, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(strName, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX _
Or Mid(strName, 1, 5) = "Label" Then
objShape.Delete
End If
Next
Next
End Sub
I only added the two pass for loop to ensure the objects are deleted, but even this doesn't delete the remaining items. The issue I have is that I end up with controls that were not deleted in the workbook.
I'm only trying to delete checkboxes and labels where in the case of checkboxes the name is prefixed with:
Public Const CHECKBOX_PREFIX As String = "chkbx"
Labels are prefixed with:
Public Const LABEL_PREFIX As String = "lbl"
The 3rd search comparing with 'Label' is an attempt to mop up but even this doesn't catch all.
Is there any way to delete all shapes / ole objects within a range?
Fixed, I rewrote the sub-routine after a google search on how to delete shapes within a range:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim objTopLeft As Range, objBotRight As Range
Dim objRange As Range, objShape As Shape
Set objRange = Sheet1.Range(COLUMN_HEADINGS)
With objRange
Set objTopLeft = .Cells(1).Address(0, 0)
Set objBotRight = .cell(.Cells.Count).Address(0, 0)
For Each objShape In ActiveSheet.Shapes
If Mid(objShape.Name, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(objShape.Name, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX Then
If Not Intersect(objTopLeft, objShape.TopLeftCell) Is Nothing And _
Not Intersect(objBotRight, objShape.BottomRightCell) Is Nothing Then
objShape.Delete
End If
End If
Next
End With
End Sub
I'm having a problem populating a userform. I found some code online that does exactly what I want and the 'example' file works perfectly. When I modify it to my needs, it gives me an error message on the following line:
frmModifyData.Skill.Value = Application.VLookup(cmbItemName.Value, Sheets("Enrolled").Range(vrange), 1, False)
Here's the entire code I'm working with:
Dim NotNow As Boolean
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOkay_Click()
NotNow = True
N = Application.Match(Me.cmbItemName.Value, Range("AB:AB"), 0)
Cells(N, 1).Value = Me.frmEnterData.Skill.Text
Cells(N, 2).Value = Me.frmEnterData.txtCLASS.Text
Cells(N, 3).Value = Me.frmEnterData.LastName.Text
NotNow = False
End Sub
Private Sub cmbItemName_Change()
If NotNow Then Exit Sub
vrange = "FirstField"
'LINE WITH THE PROBLEM
frmModifyData.Skill.Value = Application.VLookup(cmbItemName.Value, Sheets("Enrolled").Range(vrange), 1, False)
'END OF LINE WITH THE PROBLEM (though it could affect the two lines of code below...)
frmModifyData.txtCLASS.Value = Application.VLookup(cmbItemName.Value, Sheets("Enrolled").Range(vrange), 2, False)
frmModifyData.LastName.Value = Application.VLookup(cmbItemName.Value, Sheets("Enrolled").Range(vrange), 3, False)
End Sub
Private Sub UserForm_Initialize()
frmModifyData.cmbItemName.RowSource = "FirstField"
End Sub
'FirstField' is a named range that is defined this way
=OFFSET(Enrolled!$AB$3,0,0,COUNTA(Enrolled!$AB:$AB)-1,3)
Column AB holds the "Full Name" of the user. This is what I'm using to find an individual. Once I pick a name using a drop-down box on the userform, it gives me the message Could not set the Value property. Invalid property value.
How do I fix this so it works?
Try breaking your code down a little and make sure your vlookup is working...
Dim v
v = Application.VLookup(cmbItemName.Value, Sheets("Enrolled").Range(vrange), 1, False)
If Not IsError(v) Then
frmModifyData.Skill.Value = v
Else
Msgbox cmbItemName.Value & " was not found!"
End If