I am currently working on a userform. In this userform, data is entered in textbox4 and data is placed in textbox6 via commandbutton3 based on Vlookup. However, the vlookup must retrieve its data from the worksheet "DB - verzamelformulier" in the range A: B. Currently I get the error message: 424 object required. Can anybody help me with the code?
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DB - verzamelformulier")
With ws
Texbox6.Formula = "VLookup(TextBox4.Value, DB - verzamelformulier!$A:$B), 2, False)"
End With
End Sub
Interesting approach, but you can't assign formulae to textboxes, only cells. Try out a function like this:
Function VerzamelFormulier(LookUpValue As Variant) As Variant
Dim WS As Worksheet
Dim R As Range
Set WS = ThisWorkbook.Worksheets("DB - verzamelformulier")
Set R = WS.Range("A:A").Find(LookUpValue, LookIn:=xlValues, Lookat:=xlWhole)
If R Is Nothing Then
' The value wasn't found.
Else
' Return the value from the cell in the same row and column B.
VerzamelFormulier = WS.Cells(R.Row, 2)
End If
End Function
Call it on TextBox4's change event so that whenever it's changed TextBox6's value is updated.
Private Sub TextBox4_Change()
TextBox6.Value = VerzamelFormulier(TextBox4.Value)
End Sub
Using Vlookup:
Option Explicit
Sub test()
Dim varResults As Variant
varResults = Application.VLookup(TextBox4.Value, ThisWorkbook.Worksheets("Db - verzamelformulier").Range("A:B"), 2, False)
If Not IsError(varResults) Then
'If there is a results
TextBox6.Value = varResults
Else
'If there is no result
End If
End Sub
Related
I have data in Column A in excel..I am iterating through column and i need to find if a cell value has hyperlink init.
LR=Activeworkbook.Worksheets("Emp").Range("A65000").End(xlup).Row
for j=1 to LR
if Thisworkbooks.Worksheets("Emp").cells(j,1)="" then 'Logic to find hyperlink
'Function
end if
next
Identify Cells Containing Hyperlinks
As Red Hare already mentioned in the comments, it is best tested with something like the following:
Dim cell As Range: Set cell = Sheet1.Range("A1")
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
that is, using the Hyperlinks.Count property of the Hyperlinks object returned by the cell's Hyperlinks property which is a collection of hyperlinks in a range (in this case, a single cell). For a single cell, the Count property will return only 0 or 1 so you could actually use
If cell.Hyperlinks.Count = 1 Then ' has a hyperlink
instead.
Example Code
Option Explicit
Sub IdentifyCellsWithHyperlink()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, modify accordingly.
Dim ws As Worksheet: Set ws = wb.Worksheets("Emp")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim cell As Range
For Each cell In rg.Cells
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
Next cell
End Sub
Here is something that can be used to run through each row to determine if it can be set as a hyperlink. Kinda hard to figure out what the range of possible solutions are that will work for you without fully understanding the context...
Private Sub cmdFollowLink_Click()
CreateHyperlink Me!cmdFollowLink, Me!txtSubAddress, _
Me!txtAddress
End Sub
Sub CreateHyperlink(ctlSelected As Control, _
strSubAddress As String, Optional strAddress As String)
Dim hlk As Hyperlink
Select Case ctlSelected.ControlType
Case acLabel, acImage, acCommandButton
Set hlk = ctlSelected.Hyperlink
With hlk
If Not IsMissing(strAddress) Then
.Address = strAddress
Else
.Address = ""
End If
.SubAddress = strSubAddress
.Follow
.Address = ""
.SubAddress = ""
End With
Case Else
MsgBox "The control '" & ctlSelected.Name _
& "' does not support hyperlinks."
End Select
End Sub
I am looking for a little assistance with the VBA code in the workbook I have been working on. There is a userform with dependent dropdowns that pulls their values from "Master Sheet" in the workbook. The drop downs are functioning fine. However I have two roadblocks that I have now been able to get past. The first, The dropdowns allow the selection of "Category, Make, Model, and Add To". In the Master Sheet, "Category, Make, Model" Run from Columns A:C. Columns D:G have the equipment's, "Weight, Length, Width, Depth" information. I have not been able to have the information from columns A:F be copied based off the model selection. I have been trying have it paste in a test are for functionality with no luck. However once that would be functioning the "Add To" combo box selection in the user form would specify the range in the ECA worksheet to place that data. In the combo box selection, selecting "Keep" would place that information in range S3:Y16, "Remove" would be range S18:Y32, and "Final" would be range S35:Y47. Since numerous pieces of equipment would be added into each section when adding a piece of equipment it would place that entry in the next empty row of that range.
Link To Workbook
Picture Of Worksheets
Master Sheet
ECA Sheet
Dependent Drop Down Code
Private Sub cmbAddTo_Click()
'code needed to copy and add to selected range
End Sub
Private Sub cmdCancel_Click()
frmUser.Hide
End Sub
Private Sub UserForm_Initialize()
cmbCategory.RowSource = DynamicList(1, Null, 1, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbCategory_Change()
cmbMake.RowSource = DynamicList(1, cmbCategory.Value, 2, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbMake_Change()
cmbModel.RowSource = DynamicList(2, cmbMake.Value, 3, "Master Sheet", "Drop Down")
End Sub
Here is how I did it:
Function wsECA: Refers to the ECA worksheet
Enum SectonType: Numbers the sections
Function ECASection: Returns the range of a section
Function ECANewRow: Returns the range of the next empty row
Sub AddECANewRow: Add variable number of values to the new section row
Code
Public Enum SectonType
stExistingToRemain = 1
stRemoving
stFinal
End Enum
Public Sub AddECANewRow(SectionNumer As SectonType, ParamArray Values() As Variant)
Dim NewRow As Range
Set NewRow = ECANewRow(SectionNumer)
NewRow.Resize(1, UBound(Values) + 1).Value = Values
End Sub
Public Function wsECA() As Worksheet
Set wsECA = ThisWorkbook.Worksheets("ECA")
End Function
Public Function ECANewRow(ByVal SectionNumer As SectonType) As Range
Const LastColumn = 10
Dim Section As Range
Set Section = ECASection(SectionNumer)
Dim LastUsedRow As Long
Dim ColumnLastUsedRow As Long
For c = 2 To LastColumn
With Section.Columns(c)
ColumnLastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If ColumnLastUsedRow > LastUsedRow Then LastUsedRow = ColumnLastUsedRow
End With
Next
LastUsedRow = LastUsedRow - Section.Row + 1
Set ECANewRow = Section.Cells(LastUsedRow + 1, 2).Resize(1, LastColumn - 1)
End Function
Function ECASection(ByVal SectionNumer As SectonType) As Range
Dim Target As Range
With wsECA
Set Target = Range("P2", .Cells(.Rows.Count, "P").End(xlUp))
End With
Dim MergedArea As Range
Dim Cell As Range
For Each Cell In Target
If Cell.MergeArea.Rows.Count > 1 Then
If MergedArea Is Nothing Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
ElseIf MergedArea.Address <> Cell.MergeArea.Address Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
End If
If SectionNumer = 0 Then Exit For
End If
Next
If Not MergedArea Is Nothing Then
Set ECASection = Range(MergedArea, MergedArea.EntireRow.Columns("AA"))
End If
End Function
Test
Application.Goto ECANewRow(stExistingToRemain), True
AddECANewRow stExistingToRemain,"Remain" ,3,,"Ford", "Mustang"
Application.Goto ECANewRow(stRemoving), True
AddECANewRow stFinal,"Removing" ,3,,"Chevy", "Tahoe"
Application.Goto ECANewRow(stFinal), True
AddECANewRow stRemoving,"Final" ,3,,"Dodge", "Journey"
I want to populate a comboBox with the drop-down values found in a particular cell, say C10.
C10 uses Excel's Data Validation functionality to limit the values that can be entered into a cell to a drop-down list. I want to use this list to populate the comboBox in a vba userForm.
Currently my approach is to use:
Range("C10").Validation.Formula1
Here is 3 arbitrary examples of what this can return:
"=Makes"
"=INDIRECT(C9 & "_MK")"
"0;1;2;3;4;5;6;7;8;9;10"
My approach is to evaluate this and try to form it into a usable range that can be used to set the RowSource property of my comboBox. However, I can't account for every feasible case that can be returned.
Surely there is a short and simple way to achieve what I want without without coding an exception for every case.
What is the correct way of doing this?
However, I can't account for every feasible case that can be returned.
You will have to account for it separately. There is no direct way to get those values.
Here is a quick code GetDVList() that I wrote which will handle all your 3 scenarios.
The below code will return the values of the Data Validation list in an array from which you can populate the Combobox. I have commented the code so you should not have a problem understanding it but if you do then simply ask.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim rng As Range
Dim i As Long
Dim cmbArray As Variant
'~~> Change this to the relevant sheet and range
Set rng = Sheet1.Range("A1")
'~~> Check if range has data validation
On Error Resume Next
i = rng.SpecialCells(xlCellTypeSameValidation).Count
On Error GoTo 0
'~~> If no validation found then exit sub
If i = 0 Then
MsgBox "No validation found"
Exit Sub
End If
'~~> The array of values
cmbArray = GetDVList(rng)
'~~> You can transfer these values to Combobox
For i = LBound(cmbArray) To UBound(cmbArray)
Debug.Print cmbArray(i)
Next i
End Sub
Function GetDVList(rng As Range) As Variant
Dim tmpArray As Variant
Dim i As Long, rw As Long
Dim dvFormula As String
dvFormula = rng.Validation.Formula1
'~~> "=Makes"
'~~> "=INDIRECT(C9 &_MK)"
If Left(dvFormula, 1) = "=" Then
dvFormula = Mid(dvFormula, 2)
rw = Range(dvFormula).rows.Count
ReDim tmpArray(1 To rw)
For i = 1 To rw
tmpArray(i) = Range(dvFormula).Cells(i, 1)
Next i
'~~> "0;1;2;3;4;5;6;7;8;9;10"
Else
tmpArray = Split(dvFormula, ",") '~~> Use ; instead of , if required
End If
GetDVList = tmpArray
End Function
Please, test the next code. It works with the assumption that a List Validation formula can only return a Range or a list (array). Theoretically, it should evaluate any formula and extract what it returns, in terms of a Range or a List:
Sub comboListValidation()
Dim cel As Range, arr, arrV
Dim cb As OLEObject 'sheet ActiveX combo
Set cb = ActiveSheet.Shapes("ComboBox1").OLEFormat.Object
Set cel = ActiveCell 'instead of active cell you can use what you need
'even a cell resulted from iteration between `sameValidation` range
arrV = isCellVal(cel) 'check if chell has validadion (and DropDown type)
If Not arrV(0) Then
MsgBox "No validation for cell """ & cel.Address & """.": Exit Sub
ElseIf Not arrV(1) Then
MsgBox "cell """ & cel.Address & """ has validation but not DropDown type.": Exit Sub
End If
arr = listValidation_Array(cel)
With cb.Object
.Clear 'clear the existing items (if any)
.list = arr 'load the combo using arr
End With
MsgBox "Did it..."
End Sub
Private Function listValidation_Array(cel As Range) As Variant
Dim strForm As String, rngV As Range, strList As String, arr
strForm = cel.Validation.Formula1 'extract Formula1 string
On Error Resume Next
Set rngV = Application.Evaluate(strForm) '!!!try setting the evaluated range!!!
If Err.Number = 424 Then 'if not a Range, it must be a list (usually, comma separated)
Err.Clear: On Error GoTo 0
listValidation_Array = Split(Replace(strForm, ";", ","), ",") 'treat the ";" sep, too
Else
On Error GoTo 0
listValidation_Array = rngV.Value 'extract the array from range
End If
End Function
Function isCellVal(rng As Range) As Variant
Dim VType As Long
Dim boolValid As Boolean, boolDropDown As Boolean
On Error Resume Next
VType = rng.Validation.Type 'check if validation exists
On Error GoTo 0
If VType >= 1 Then 'any validation type
boolValid = True
If VType = 3 Then boolDropDown = True 'dropDown type
End If
ReDim arr(1) : arr(0) = boolValid: arr(1) = boolDropDown
isCellVal = arr
End Function
So I have two sheets, one with info and one where the info should be copied too.
If DONE is marked yes, all the info in that row will be copied to the sheet called "FullpInfo2 (with a button). In the "template" on the picture. But I have no idea what to do now. Could someone just give me an idea how to continue this?
If I add a new row and giving it value "yes", it should rewrite the previous (Name, Drink, Food, Vehicle)
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("PersonalInfo")
Set Target = ActiveWorkbook.Worksheets("FullpInfo")
For Each c In Source.Range("E2:E100") ' Do 100 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
Target.Cells("B15").Value = Source.Cells("A").Value ' I dont know what to do here..
End If
Next c
End Sub
You could try:
Option Explicit
Sub CopyYes()
Dim cell As Range
Dim Source As Worksheet, Target As Worksheet
With ThisWorkbook
Set Source = .Worksheets("PersonalInfo")
Set Target = .Worksheets("FullpInfo")
End With
With Target
'Formatting
Call Module1.Formatting(.Range("B3"), "Name", "Titles")
Call Module1.Formatting(.Range("D3"), "Drink", "Titles")
Call Module1.Formatting(.Range("B6"), "Food", "Titles")
Call Module1.Formatting(.Range("D6"), "Vehicle", "Titles")
For Each cell In Source.Range("E2:E100")
If cell.Value = "yes" Then
'Values
Call Module1.Formatting(.Range("B4"), Source.Range("A" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("D4"), Source.Range("C" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("B7"), Source.Range("B" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("D7"), Source.Range("D" & cell.Row).Value, "Values")
End If
Next cell
End With
End Sub
Sub Formatting(ByVal rng As Range, str As String, strType As String)
With rng
.Value = str
.Font.Bold = True
If strType = "Values" Then
.Font.Color = vbBlue
End If
End With
End Sub
Sub RunCompare()
Call compareSheets("Latest", "SFDC")
End Sub
Sub compareSheets(shtLatest As String, shtSFDC As String)
Dim mycell As Range
Dim mydiffs As Integer
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For Each mycell In ActiveWorkbook.Worksheets(shtSFDC).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtLatest).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
'Display a message box to demonstrate the differences
MsgBox mydiffs & " differences found", vbInformation
ActiveWorkbook.Sheets(SFDC).Select
End Sub
Sub RunCompare()
compareSheets "Latest", "SFDC"
End Sub
'Compares two sheets and colours yellow any cell in sheet2 that is not the same as in sheet 1
Sub compareSheets(sheet1 As String, sheet2 As String)
Dim rCell1 As Range
Dim rCell2 As Range
Dim nDiffs As Long ' Using a long because Integer may one day be too small
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets(sheet1)
Set ws2 = ActiveWorkbook.Worksheets(sheet2)
For Each rCell1 In ws1.UsedRange.Cells
Set rCell2 = ws2.Range(rCell1.Address)
If rCell1.Value <> rCell2.Value Then
rCell2.Interior.Color = vbYellow
nDiffs = nDiffs + 1
End If
Next rCell1
Debug.Print nDiffs
End Sub
This should help you produce a workable solution. In your code, the 'For Each mycell' line creates a loop on each 'Range' object in 'UsedRange' not on each individual cell.
Your 'Subscript out of range' may become from invalid sheet names.
Are you sure that active book when you call macro is one with Latest and SFDC worksheets.
Not directly related to problem, but I would suggest you to change your function prototype to
Sub compareSheets(ByVal shtLatest As Worksheet, ByVal shtSFDC As Worksheet)
replace all ActiveWorkbook.Worksheets(shtSFDC) with shtSFDC (same for shtLatest) and finally replace call with
Call compareSheets(ActiveWorkbook.Worksheets("Latest"), ActiveWorkbook.Worksheets("SFDC"))
or directly with code name:
Call compareSheets(sheet1, sheet2)
That is clearer as compareSheets expects sheets, not text.