Doing a lookup using vba - excel

I have a value (variant) strCompany in my workbook. I would like to determine if this value exists in column A of another workbook, tmp_workbook. If it does not exist there should be a message box. Does the following code make sense (I define the variables tmp_workbook and strCompany earlier in my code)? If not perhaps you can suggest a better way?
On Error GoTo ErrorHandler
Set value_exists_in_table = tmp_workbook.ActiveSheet.Range("A1:A100000").Find(strCompany)
ErrorHandler:
Select Case Err.Number
Case 9, 91
MsgBox "The company " & strCompany & " was not found."
Exit Sub
End Select

The Range.Find method inherits many parameters from the last time it was used; commonly by the user on the worksheet. You should explicitly specify several more commonly used parameters like LookAt:xlWhole or LookAt:xlPart and LookIn:=xlValues or LookIn:=xlFormulas.
I typically stay away from .Find for exact matches in a single row or column. The Excel Application object's native MATCH function does an excellent job of locating a value.
dim rw as variant
with worksheets("Sheet1")
rw = application.match(strCompany, .Columns(1), 0)
if not iserror(rw) then
value_exists_in_table = .cells(rw, 1).value
debug.print value_exists_in_table & " found in row " & rw
else
debug.print "The company " & strCompany & " was not found."
end if
end with

Related

Excel VBA code error '1004' while searching external links

I need your help. I found the attached vba code but when I run the code I am getting a very strange 1004 error. Could you please give an explanation or try to fix this error?
Thank you so much all!
' Module to remove all hidden names on active workbook
Sub Remove_Hidden_Names()
' Dimension variables.
Dim xName As Variant
Dim Result As Variant
Dim Vis As Variant
' Loop once for each name in the workbook.
For Each xName In ActiveWorkbook.Names
'If a name is not visible (it is hidden)...
If xName.Visible = True Then
Vis = "Visible"
Else
Vis = "Hidden"
End If
' ...ask whether or not to delete the name.
Result = MsgBox(prompt:="Delete " & Vis & " Name " & _
Chr(10) & xName.Name & "?" & Chr(10) & _
"Which refers to: " & Chr(10) & xName.RefersTo, _
Buttons:=vbYesNo)
' If the result is true, then delete the name.
If Result = vbYes Then xName.Delete
' Loop to the next name.
Next xName
End Sub
These Excel built-in range names appear in the Excel name manager when using SUMIFS,IFERROR, COUNTIFS and other formulas.
There are a lot of ways around this, as suggested in the comments.
You can add either of these:
If Not xName.Name Like "_xlfn*" Then
'Or
If InStr(xName.Name, "_xlfn") = 0 Then
first thing in the loop (don't forget to close it), or something similar.
If you for some reason still want to see it, you can add it to the delete if:
If Result = vbYes And Not xName.Name Like "_xlfn*" Then xName.Delete

VBA code processing stops when adding or removing a named range

I have an excel sheet where I am trying to create a named range dynamically in VBA. Maybe there's a better way to do it, but the existing way I am using should work based on multiple articles and tickets I have read on the topic. Using this method fails for me because the processing stop without an error when running this code. The range gets created or deleted on the line where processing stops, but of course I need processing to continue through the rest of the code. You should be able to replicate this issue in any excel sheet if you use this code snippet and run the test caller in testsub():
Option Explicit
Sub testsub()
Call SetDataRange("TestRange", ActiveWorkbook.Sheets("Sheet1"), 1, 2)
End Sub
Sub SetDataRange(RangeName As String, TargetSheet As Worksheet, LeftColumn As Integer, RightColumn As Integer)
On Error GoTo Fail
Dim WB As Workbook
Dim CRLastCell As Range
Dim rngDataRange As Range
Set WB = ActiveWorkbook
With TargetSheet
Set CRLastCell = .Cells(.Rows.Count, "A").End(xlUp)
Set rngDataRange = .Range(.Cells(1, LeftColumn), .Cells(CRLastCell.Row, RightColumn))
On Error Resume Next
Debug.Assert False ' Forcing a break for debug purposes. The next line will cause the processing to stop without an error if the named range exists
WB.Names.Item(RangeName & "_" & .Name).Delete
Err.Clear
On Error GoTo Fail
Debug.Assert False ' Forcing a break for debug purposes. The next line will cause the processing to stop without an error
WB.Names.Add Name:=RangeName & "_" & .Name, RefersTo:="=" & .Name & "!" & rngDataRange.Address, Visible:=True
End With
Debug.Print RangeName & "_" & TargetSheet.Name & " " & ActiveWorkbook.Names.Item(RangeName & "_" & TargetSheet.Name).RefersTo
Exit Sub
Fail:
Debug.Print "Error: " & vbCrLf & Err.Number & vbCrLf & Err.Description
End Sub
This is not my original code, but a recreation of the code I placed in a new workbook for simplest reproducible conditions.
Thanks
As suggested by EvR, I removed the code which was trying to delete the named range, thereby utilizing the feature in the names.add function that overwrites an existing name. This bypasses the issue without any undesired side effects, so I will consider this an answer to the question.

Create a VBA version of dictionaries with 2 values per key

I am trying to make my excel macro dynamic. The excel macro essentially looks at only 2 columns, one which contains the name and the other contains the numeric part. I have my macro working perfectly, the only problem is that it is hard coded when I created the program. In my code, I hard coded the name in column 2 and the numeric part in column 3. However, that is not the case in real life. The name and numeric data could appear in column 1 and 5, for example. I've been manually rearranging the data in the columns so that it fits into what hard coded. However, I want to make this process dynamic and less manual work for the user.
There are 5 different versions of spreadsheets this macro will be used on and in each spreadsheet, the name and number columns are different. I am looking to make a user form box of some sort, where the user selects "Vendor XYZ" and since Vendor XYZ always sends their data sheets the same way I know that Vendor XYZ's name column is 2 and number is 4. So I was thinking that the dictionary would be something in the form of {Vendor XYZ: 2,4} (where the first number is the name column and the second number is the numeric columnnumber...I know the syntax is wrong)
I think my work around this would be to hard code the different vendors and then use if statements ( I haven't tried it yet)
I will have a user input/dropdown box of 5 different vendors. Then something like
If userinput="A"
then namecol=2 and numcol=1
If userinput="B"
then namecol="3" and numcol="4"
I don't know if that would even work. The problem with that is that the number of vendors is small now, but will be scaling up and I can't do that if we have 100 or 1000 vendors.
Any ideas?
Depending on how your initial dataset is retrieved, you can use something like this:
Public Function GetHeaderIndices(ByVal InputData As Variant) As Scripting.Dictionary
If IsEmpty(InputData) Then Exit Function
Dim HeaderIndices As Scripting.Dictionary
Set HeaderIndices = New Scripting.Dictionary
HeaderIndices.CompareMode = TextCompare
Dim i As Long
For i = LBound(InputData, 2) To UBound(InputData, 2)
If Not HeaderIndices.Exists(Trim(InputData(LBound(InputData, 1), i))) Then _
HeaderIndices.Add Trim(InputData(LBound(InputData, 1), i)), i
Next
Set GetHeaderIndices = HeaderIndices
End Function
This Function takes an array as an input and gives the user a dictionary with the indices of the headers from the input.
If you are smart (and I say this because too many users just don't use tables) you will have your data in a table, and you will have named that table. If you did, you could do something like this:
Sub DoSomething()
Dim MyData as Variant
MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value
End Sub
So, if you data looked like this:
Foo Baz Bar
1 Car Apple
3 Van Orange
2 Truck Banana
The function would give you a dictionary like:
Keys Items
Foo 1
Baz 2
Bar 3
Then your subroutines could do something like this:
Sub DoEverything()
Dim MyData as Variant
MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value
DoSomething(MyData)
End Sub
Sub DoSomething(ByRef MyData as Variant)
Dim HeaderIndices as Scripting.Dictionary
Set HeaderIndices = GetHeaderIndices(MyData)
Dim i as Long
' Loop through all the rows after the header row.
For i = LBound(MyData, 1) + 1 to Ubound(MyData, 1)
If MyData(i, HeaderIndices("Baz")) = "Truck" Then
?MyData(i, HeaderIndices("Foo"))
?MyData(i, HeaderIndices("Baz"))
?MyData(i, HeaderIndices("Bar"))
End If
Next
End Sub
This does require a reference to Scripting.Runtime so if you don't want to add a reference you will need to change any reference to As Scripting.Dictionary to As Object and any New Scripting.Dictionary to CreateObject("Scripting.Dictionary").
Alternatively, I use the following code module to take care of adding references programmatically for all my users:
Public Sub PrepareReferences()
If CheckForAccess Then
RemoveBrokenReferences
AddReferencebyGUID "{420B2830-E718-11CF-893D-00A0C9054228}"
End If
End Sub
Public Sub AddReferencebyGUID(ByVal ReferenceGUID As String)
Dim Reference As Variant
Dim i As Long
' Set to continue in case of error
On Error Resume Next
' Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=ReferenceGUID, Major:=1, Minor:=0
' If an error was encountered, inform the user
Select Case Err.Number
Case 32813
' Reference already in use. No action necessary
Case vbNullString
' Reference added without issue
Case Else
' An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Private Sub RemoveBrokenReferences()
' Reference is a Variant here since it requires an external reference.
' It isnt possible to ensure that the external reference is checked when this process runs.
Dim Reference As Variant
Dim i As Long
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set Reference = ThisWorkbook.VBProject.References.Item(i)
If Reference.IsBroken Then
ThisWorkbook.VBProject.References.Remove Reference
End If
Next i
End Sub
Public Function CheckForAccess() As Boolean
' Checks to ensure access to the Object Model is set
Dim VBP As Variant
If Val(Application.Version) >= 10 Then
On Error Resume Next
Set VBP = ThisWorkbook.VBProject
If Err.Number <> 0 Then
MsgBox "Please pay attention to this message." _
& vbCrLf & vbCrLf & "Your security settings do not allow this procedure to run." _
& vbCrLf & vbCrLf & "To change your security setting:" _
& vbCrLf & vbCrLf & " 1. Select File - Options - Trust Center - Trust Center Settings - Macro Settings." & vbCrLf _
& " 2. Place a checkmark next to 'Trust access to the VBA project object model.'" _
& vbCrLf & "Once you have completed this process, please save and reopen the workbook." _
& vbCrLf & "Please reach out for assistance with this process.", _
vbCritical
CheckForAccess = False
Err.Clear
Exit Function
End If
End If
CheckForAccess = True
End Function
And I have the following command in each Workbook_Open event (less than ideal, but only good solution I have so far)
Private Sub Workbook_Open()
PrepareReferences
End Sub

VBA macro which writes a new macro from string on the fly

Is it possible to create Excel VBA macro from a string variable?
Suppose we have FirstMacro:
Sub FirstMacro()
Dim MyString
MyString = "Sub SecondMacro()" & Chr(13) & Chr(10) & "MsgBox " & Chr(34) & "Hello" & Chr(34) & Chr(13) & Chr(10) & "End Sub"
Debug.Print MyString
'Here be code that magicly creates SecondMacro
End Sub
Running the macro, I want to create SecondMacro which is stored in VBA string variable. The second macro can be created either below in the same module or in a new module.
So the second macro from string looks like this:
Sub SecondMacro()
MsgBox "Hello"
End Sub
Sure is possible. It should be noted that you can't add/delete from the module you're running code in.
This will append the code at the end of the module. If you can avoid this though you should, I only use it for adding code to buttons that I've added programatically.
With Workbooks(ThisWorkbook.Name).VBProject.VBComponents("MyModuleHere").CodeModule
.InsertLines .CountOfLines + 1, "Sub... End Sub"
End With
So to add to the "MyModuleHere" code module (assuming you have a module named that), drop this in:
Sub addcode()
Dim subtext As String
subtext = "Sub PrintStuff" & vbCrLf & "msgbox ""Hello World""" & vbCrLf & "End Sub"
With Workbooks(ThisWorkbook.Name).VBProject.VBComponents("MyModuleHere").CodeModule
.InsertLines .CountOfLines + 1, subtext
End With
End Sub
As usual, CPearson adds some really useful insight:
http://www.cpearson.com/excel/vbe.aspx
With regard to removing code, which I think you're hinting at in your comment, I use the below function to find a sub name, and remove it (this assumes that I will know the length of the sub):
Function ClearModule(strShapeName As String)
Dim start As Long
Dim Lines As Long
Dim i As Variant, a As Variant
With Workbooks(ThisWorkbook.Name).VBProject.VBComponents("MyModuleHere").CodeModule
For i = .CountOfLines To 1 Step -1
If Left(.Lines(i, 1), 8 + Len(strShapeName)) = "Sub " & strShapeName & "_Cli" Then
.DeleteLines i, 6
End If
Next
End With
End Function
Here you have more or less all variations which, hopefully, will solve your problem. To test this code copy all of it in a normal code module (by default "Module1") Rename it as "Remin" and write "FirstMacro" in cell A1 of the worksheet you activate, a number in cell A2. Then run the first of the following procedures directly from the VBE window.
Sub SelectMacroToRun()
' 04 Apr 2017
Dim MacroName As String
Dim Arg1 As String
Dim Outcome As Long
With ActiveSheet
MacroName = .Cells(1, 1).Value
Arg1 = .Cells(2, 1).Value
End With
On Error Resume Next
Outcome = Application.Run(ActiveSheet.name & "." & MacroName, Arg1)
If Err Then
MsgBox "The macro """ & MacroName & """ wasn't found", _
vbInformation, "Error message"
Else
If Outcome <> xlNone Then MsgBox "Outcome = " & Outcome
End If
End Sub
Private Function FirstMacro(Optional ByVal Dummy As String) As Long
MsgBox "First Macro"
FirstMacro = xlNone
End Function
Private Function SecondMacro(Arg1 As Long) As Long
MsgBox "Second Macro" & vbCr & _
"Argument is " & Arg1
SecondMacro = Arg1 * 111
End Function
The code will run the FirstMacro, reading the name from the worksheet. Change that name to "SecondMacro" to call the second macro instead. The second macro requires an argument, the first only accepts it and does nothing with it. You don't need to pass any argument, but this code shows how to pass (as many as you want, comma separated) and it also shows how to ignore it - the argument is passed to a dummy variable in the FirstMacro, and the function also returns nothing.
Application.Run "Remin" & MacroName, Arg1
Would just run the macro (it could be a sub). Omit the argument if you don't want to pass an argument. "Remin" is the name of the code sheet where the called macro resides. This name could be extended to include the name of another workbook. However, if the called macro isn't in the same module as the caller it can't be Private.

EXCEL VBA WorksheetFunction.CountIf() in a SELECT CASE

I know that it is possible to use If statement but out of curiosity, as mentioned in the title, is it possible to use SELECT statement to do something as BOLDED below? I've submitted my whole Sub as below for better understanding:
Sub addNewCust_Click()
Dim response As String
response = Application.InputBox(prompt:="", Title:="New customer name", Type:=2)
Select Case response
Case False
Exit Sub
'Check if response is not an empty value AND record found in "CustomerList"
Case Is <> "" & WorksheetFunction.CountIf(Worksheets("CustomerList").Range("B:B"), response) > 0
MsgBox "'" & response & "' already exists on this sheet."
Call addNewCust_Click
'Check if response is not an empty value and record is not found in "Customerlist"
Case Is <> "" & WorksheetFunction.CountIf(Worksheets("CustomerList").Range("B:B"), response) < 1
Sheets("CustomerList").Range("B1048576").End(xlUp).Offset(1, 0).Value = response
MsgBox "'" & response & "' successfully entered!"**
Case Else
MsgBox "Field is empty!"
Call addNewCust_Click
End Select
End Sub
Like this?
Sub addNewCust_Click()
Dim response As String
response = Application.InputBox(prompt:="", Title:="New customer name", Type:=2)
Select Case response
Case False: Exit Sub
'Check if response is not an empty value AND record found in "CustomerList"
Case Is <> ""
If WorksheetFunction.CountIf(Worksheets("CustomerList").Range("B:B"), response) > 0 Then
MsgBox "'" & response & "' already exists on this sheet."
Call addNewCust_Click
Else
Sheets("CustomerList").Range("B1048576").End(xlUp).Offset(1, 0).Value = response
MsgBox "'" & response & "' successfully entered!"
End If
Case Else
MsgBox "Field is empty!"
Call addNewCust_Click
End Select
End Sub
FOLLOWUP (From Comments)
Select Case is considered to be faster than If-Endif but for such a small scenario, the efficiency comparison is futile. What is more important is how you write the code
Below is another way. I love this way as things are broken down into smaller parts and everything is declared properly. I am not touching error handling below. See this for detailed analysis.
The below method is useful because
when you are looking at your code (say maybe after an year) and you know exactly what is happening since the code is commented.
Easy to maintain the code. For example if the Sheet name changes then you have to change it only at one place. The alternative is to also use Codenames
You can use the same code across all Excel platforms. If you hardcode your range, Ex: Range("B1048576") then the above code will not work in Excel 2003.
Sample Code
Sub addNewCust_Click()
Dim ws As Worksheet
Dim Lrow As Long
Dim response
'~~> Set the relevant worksheet
Set ws = ThisWorkbook.Worksheets("CustomerList")
With ws
Do
'~~> Get user response
response = Application.InputBox(prompt:="", Title:="New customer name", Type:=2)
Select Case response
Case False: Exit Sub '<~~ If user presses cancel or closes using 'X'
Case "": MsgBox "Field is empty!" '<~~ If user enters a blank entry
Case Else
'~~> Check if the entry exists
If WorksheetFunction.CountIf(.Range("B:B"), response) > 0 Then
MsgBox "'" & response & "' already exists on this sheet."
Else
'~~> Get last Row
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
'~~> Add the new entry
.Range("B" & Lrow).Value = response
MsgBox "'" & response & "' successfully entered!"
Exit Do 'OR Exit Sub (As Applicable)
End If
End Select
Loop
End With
End Sub

Resources