I have a simple macro that goes through a series of sheets, gathering names based on a data inputted, then puts it all in a nicely formatted Word document. I have most of it figured out, but one bug is annoying me. It has to do with the code that gets the cell phone number based on the name. Here is the function:
Function findCell(namePerson As String) As String
Dim splitName As Variant
Dim lastName As String
Dim firstName As String
splitName = Split(namePerson, " ")
lastName = splitName(UBound(splitName))
ReDim Preserve splitName(UBound(splitName) - 1)
firstName = Join(splitName)
For Each b In Worksheets("IT").Columns(1).Cells
If b.Value = lastName Then
If Sheets("IT").Cells(b.row, 2).Value = firstName Then findCell = Sheets("IT").Cells(b.row, 4).Value
End If
Next
End Function
The cellphone numbers are on its own sheet called "IT". The first column has the last name, the second column has the first name, and the forth column has the cell phone number. Some people have multiple parts for the first name, and that's why you see some of that weird splitting, ReDim-ing and joining back together. That part works just fine.
The problem arises when you have multiple people with the same last name. The function would find someone with the right last name, going through the first If statement. Then it would compare the first name. If it matches, it would return the value of the cell phone number like it should. After that, the for loop stops, even if the first name doesn't match up. So if someone happens to the same last name, but the first name doesn't check up, it returns nothing.
I've tried putting the return call outside of the loop all together, and it still doesn't make a difference.
Since you're not using a database, a primary key column might be difficult. With your current set up you could try this.
It
doesn't look through every single cell in the column
uses Option Explicit
will return the first find and exit
will be indifferent to upper/lower case and leading/trailing white space.
.
Option Explicit
Function findCell(namePerson As String) As String
Dim splitName As Variant
Dim lastName As String
Dim firstName As String
splitName = Split(namePerson, " ")
lastName = splitName(UBound(splitName))
ReDim Preserve splitName(UBound(splitName) - 1)
firstName = Join(splitName)
Dim ws As Worksheet, lastrow As Long, r As Long
Set ws = Worksheets("IT")
lastrow = ws.Cells(1, 1).End(xlDown).Row 'or whatever cell is good for you
For r = 1 To lastrow
If UCase(Trim(ws.Cells(r, 1))) = UCase(Trim(lastName)) _
And UCase(Trim(ws.Cells(r, 2))) = UCase(Trim(firstName)) Then
findCell = ws.Cells(r, 4)
Exit For
End If
Next r
End Function
It seems like you're postponing dealing with the real issue by trying to fix this one.
You're running into issues because your "keys" (name) aren't unique. You've worked around one naming clash, and now you're trying to work around another one.
What about getting a key (like a GUID) that you know will be unique? Then there won't be the need to work around this any more.
Related
I've looked up info with regards to column attributes. I'm trying to perform some insertions and copying of information within an array. The crux of my issue is that I want o nest some actions within a loop, so I need to index the column by a number not letter.
The first thing I do is find a starting point based upon a header name:
Dim EnvCondCol As String
Dim EnvCondColN As Long
Dim lColVVS As Integer
lColVVS = VET_VS.UsedRange.Columns.Count ' finds last column
For n = 1 To lColVVS
If UCase(VET_VS.Cells(3, n).Value) Like "*ENVIRONMENTAL CONDITION*" Then ' All Caps when using "like"
EnvCondCol = Split(VET_VS.Cells(3, n).Address, "$")(1)
EnvCondColN = Range(EnvCondCol & 1).Column
Exit For
End If
Next n
This works and when I watch EnvCondCol and EnvCondColN is can see EnvCondCol = "I" and EnvCondColN = "9"
Eventually, I want to insert a new column, and this line generates a syntax error:
VET_VS.Range(Columns.(EnvCondColN)).EntireColumn.Insert
When I watch EnvCondColN, it is a number, and I have tried changing the dim to other types, such as integer
Also elsewhere, I want to copy information from a cell into another cell from within a loop. This generates a syntax error.
VET_VS.Range(Columns.(EnvCondColN + i)).Copy VET_VS.Range(Columns.(EnvCondColN + j))
If I replace EnvCondColN with a value like 5, then this works. Example: VET_VS.Range(Columns.(5)).EntireColumn.Insert
Why isn't the variable working as a column reference??
Thank you all for looking!
change
VET_VS.Range(Columns.(EnvCondColN)).EntireColumn.Insert
to
VET_VS.Columns(EnvCondColN).EntireColumn.Insert
I have tried so many methods from the removeduplicates, selections and scripting dictionaries and I cannot get this to work. I do understand there are multiple ways to do this but if any of you can help, that would be great.
I have one list of values that I am pulling through from another sheet (up to approx 80k rows) into cell B13 downwards. I am then trying to remove the duplicate values and cells so I am left with unique values which I can then use to perform lookups on other sheets.
Sub Address_Sage()
Dim dataBook As Workbook
Dim dict As Object
Dim Sage_Data As Worksheet, Address As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Dim rowCount As Long
Dim strVal As String
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Sage_Data")
Set sheetDest = dataBook.Sheets("Address")
Set dict = CreateObject("Scripting.Dictionary")
Set dataSource = sheetSource.Range("A3", _
sheetSource.Range("A90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
Next index
Sheets("Address").Select
rowCount = ActiveSheet.Range("B13").CurrentRegion.Rows.Count
Do While rowCount > 0
strVal = Address.Cells(rowCount, 1).Value2
If dict.exists(strVal) Then
ActiveSheet.Rows(rowCount).EntireRow.Delete
Else
dict.Add strVal, 0
End If
rowCount = rowCount - 1
Loop
'Set dict = Nothing
End Sub
It always gets stuck on strVal line. I have tried changing value2 to value1 as I only have column but no luck.
thank you
Not super experienced in VBA so I can't speak to exactly what you're doing and what your code is saying but I thought I'd share this with you. Last week I had to create a macrobook that returned the unique entries of electrical defects that different crews observed while on the job. I made a dictionary that read all of the entries in the spreadsheet and then later printed all of the unique entries. I'll post the code and try to walk you through it.
If .Range("A" & i) <> "" Then
If dict.Exists(data) Then
dict(data) = dict(data) + 1
Else
dict.Add Key:=Data, Item:="1"
End If
End If
So the code basically says if column A (i is simply an incrementer) is not empty, then we're going to read the entries of column A. Data is simply a variable and you would set it equal to the range of values you'd like read in the dictionary. Obviously dictionary keys are unique and cannot repeat, so the code asks if the key already exists in the dictionary. If so, we will add one to it's count or value. And if not we will add that key to the dictionary. At the end of your loop, your dictionary will have stored all unique entries and the number of times they appeared.
Now we can reference them or print them.
For r = 0 To dict.Count
Sheets("Results").Range("B" & iResults) = dict.Keys(r)
Sheets("Results").Range("C" & iResults) = dict(dict.Keys(r))
Next
This second piece of code is a loop from 0 to the number of entries in your dictionary. It starts at zero because the dictionary is stored like an array and VBA arrays are base zero. The first statement will print the unique keys for every r until there are no more entries in the dictionary. The second statement will print the value or items associated with them. It will be an integer value equal to the number of times that unique entry showed up in your data.
You can use this same method for other purposes as well, not just printing the data but referencing it and using it somewhere else. But I am sure you will find that the For-loop with dict.Keys(r) is the easiest way to run through your dictionary entries. Took me a few days to figure it out and it revolutionized my program. Hope this helps you out.
I'm trying to automate certain functions in an Excel file.
Here is my issue:
Table 1 contains a string is Column "Info", followed by two empty cells. For each of the rows in Table 1, I want to check if a value of Table 2, Column "Fruit" exists in column "Info" of Table 1. If so, I would like to fill in the "Color" and "Price" of Table 2 in the empty cells in Table 1.
For example, the second row contains the word "bananas", which means "Color" "Yellow" and "Price" "15" should be filled in the same columns in Table 1, row 2.
Somehow this issue seems so simple to me, but when I start to think of how to implement this, I get stuck. So unfortunately, I don't have any code available to fix. I just hope this issue isn't too vague.
I've also tried solving this issue using formulas, using MATCH and INDEX, but I couldn't get that to work either.
Here's a function that will return the row in the ListObject (Table) where the first matching word is found.
Public Function MatchFruit(ByVal sInfo As String, ByRef rFruit As Range) As Long
Dim vaSplit As Variant
Dim i As Long, j As Long
Dim rFound As Range
Dim sWhat As String
vaSplit = Split(sInfo, Space(1))
For i = LBound(vaSplit) To UBound(vaSplit)
'strip out non-alpha characters
sWhat = vbNullString
For j = 1 To Len(vaSplit(i))
If Asc(Mid(LCase(vaSplit(i)), j, 1)) >= 97 And Asc(Mid(LCase(vaSplit(i)), j, 1)) <= 122 Then
sWhat = sWhat & Mid(vaSplit(i), j, 1)
End If
Next j
'find the word in the range
Set rFound = Nothing
Set rFound = rFruit.Find(sWhat, , xlValues, xlWhole, , , False)
If Not rFound Is Nothing Then 'if it's found
'return the row in the ListObject
MatchFruit = rFound.Row - rFruit.ListObject.HeaderRowRange.Row
'stop looking
Exit For
End If
Next i
End Function
Assuming your first table is called tblData and your second table tblFruit, you would get the color using
=INDEX(tblFruit[Color],MatchFruit([#Info],tblFruit[Fruit]))
and the price similarly
=INDEX(tblFruit[Price],MatchFruit([#Info],tblFruit[Fruit]))
Long Explanation
The vaSplit assignment line uses the Split function to convert a string into an array based on a delimiter. Since your sample data was sentences, the normal delimiter is a space to split it into words. A string like
This is some line about apples.
is converted to an array
vaSplit(1) This
vaSplit(2) is
vaSplit(3) some
vaSplit(4) line
vaSplit(5) about
vaSplit(6) apples.
Next, the For loop goes through every element in the array to see if it can find it in the other list. The functions LBound and Ubound (lower bound and upper bound) are used because we can't be sure how many elements the array will have.
The first operation inside the loop is to get rid of any extraneous characters. For that, we create the variable sWhat and set it to nothing. Then we loop through all the characters in the element to see if any are outside of the range a...z. Basically, anything that's a letter gets appended to sWhat and anything that's not (a number, a space, a period) doesn't. In the end sWhat is the same as the current element with all non-alpha characters stripped out. In this example, we'd never match apples. because of the period, so it's stripped away.
Once we have a good sWhat, we now use the Find method to see if that word exists in the rFruit range. If it does, then rFound will not be Nothing and we move ahead.
Note that if it doesn't find the word in the range, then rFound will be Nothing and the function will return zero.
If the word is found, the function returns the row it was found on less the row where the ListObject starts. That way the function returns what row it is withing the data of the ListObject not on the worksheet. This is useful when incorporating into an INDEX formula. To make a formula return something, you assign that something to the formula's name.
Finally, the Exit For line simply stops looking through the array once a match was found. If you have more than one match in your data, it will only return the first one.
Troubleshooting
The most likely error that you'll find is that the function will return zero when you expect it to return a row number. That most likely means it did not find any words in the list.
If you're certain that both lists contain a matching word, here's how you troubleshoot it: After the Set rFound = line put a Debug.Print statement.
Set rFound = rFruit.Find(sWhat, , xlValues, xlWhole, , , False)
Debug.Print "." & sWhat & "."
If Not rFound Is Nothing Then 'if it's found
That will print sWhat to the Immediate Window (Ctrl+G in the VBE to see the Immediate Window). The periods around the word are so you can see any non-printable characters (like spaces). If you try to match .pears . with pears it won't match because the first one has a space at the end - and you can see that because we stuck periods before and after.
If spaces are going to be a problem, you can use the Trim$() function on sWhat to get rid of them first.
With that Debug.Print statement, you might see results like
.paers.
in which case would recognize that you have a typo.
To Dick and other people who may be interested. Like I mentioned in my last comment on the answer provided by #Dick-Kusleika, his answer didn't fully cover my initial question. Even though it gave me great insight and it did the job of filling the empty cells with the appropriate data, I was really looking for something that would do it automatically, without me having to copy-paste any formulas. So I spent some more time trying to figure it out, getting info from the internet and sparring with a colleague who shares my interest in this. And eventually I managed to get it working! (hurray!!)
Below is my solution. As I'm still a beginner, I probably did a few things that could have been done better or cleaner. So I'm really interested in your opinion about this and would love to hear any remarks or tips.
Sub check_fruit()
Dim ws As Excel.Worksheet
Dim lo_Data As Excel.ListObject
Dim lo_Fruit As Excel.ListObject
Dim lr_Data As Excel.ListRow
Dim lr_Fruit As Excel.ListRow
Dim d_Info As Variant
Dim f_Fruit As Variant
Set ws = ThisWorkbook.Worksheets("Exercise")
Set lo_Data = ws.ListObjects("tblData")
Set lo_Fruit = ws.ListObjects("tblFruit")
For Each lr_Data In lo_Data.ListRows
'check if field "Color" is empty in tblData'
If IsEmpty(Intersect(lr_Data.Range, lo_Data.ListColumns("Color").Range).Value) Then
d_Info = Intersect(lr_Data.Range, lo_Data.ListColumns("Info").Range).Value
For Each lr_Fruit In lo_Fruit.ListRows
f_Fruit = Intersect(lr_Fruit.Range, lo_Fruit.ListColumns("Fruit").Range).Value
'check for each row in tblFruit if value for field "Fruit" exists in field "Info" of tblData'
If InStr(1, d_Info, f_Fruit, vbTextCompare) <> 0 Then
Intersect(lr_Data.Range, lo_Data.ListColumns("Color").Range).Value = Intersect(lr_Fruit.Range, lo_Fruit.ListColumns("Color").Range).Value
Intersect(lr_Data.Range, lo_Data.ListColumns("Price").Range).Value = Intersect(lr_Fruit.Range, lo_Fruit.ListColumns("Price").Range).Value
End If
Next lr_Fruit
End If
Next lr_Data
End Sub
I built a sub that iterates over a sheet of business transactions for the day and addresses and attaches PDF receipts for our customers. Some customers work for the same firm, but are treated as different entities so they each receive their own email receipts. Folks from this particular firm are only identifiable as a team by their email handle, which is how I have been matching what receipts go to which email handles for which individuals.
Problem:
The problem I've encountered is that in the contacts master list (holds all of the contact information) the names are listed as first name then last name (I.E. John Snow) and on the occasion one of the external systems that information is pulled from lists the names as Last name then first name (Snow John), which isn't found by my current code. I know I could probably use InStr but to me that's a bit sloppy and the information contained in these receipts are extremely confidential. I'm struggling to come up with an consistent way to find the name regardless in a neat and eloquent way.
Possible solution I thought of was to split the names and store them into an array and then compare the different index places, but that seems inefficient. Any thoughts?
Current Code that is insufficient Note: This is only a small function from the main routine
Private Function IsEmpSameFirm(empName As String, firmEmail As String, firmName As String) As Boolean
'Finds separate employee email and compares to current email to find if same distribution
Dim empFinder As Range, firmFinder As Range
Dim columnCounter As Long
columnCounter = 1
While firmFinder Is Nothing
Set firmFinder = contactsMaster.Columns(columnCounter).Find(firmName)
columnCounter = columnCounter + 1
Wend
Set empFinder = contactsMaster.Rows(firmFinder.Row).Find(empName)
If empFinder Is Nothing Then
IsEmpSameFirm = False
ElseIf empFinder.Offset(0, 1).Value = firmEmail Then
IsEmpSameFirm = True
Else
IsEmpSameFirm = False
End If
End Function
Short answer: It is not possible
Middle answer: This implies a reasoning:
- You loop through your memories to recall which of the 2 gaven "Strings" is a name and which one is a last name. If you wish the PC to do the same, you'd need to "teach" it that -write a DataBase which contains every last name you know and if it's found there then it's a last name-
Long Answer:
What I'd do is split the text in columns, do a filter for each one and then analyze them "manually", this function may help you to split the string
Function RetriveText(InString As String, ChrToDivide, Position As Long)
On Error GoTo Err01RetriveText
RetriveText = Trim(Split(InString, ChrToDivide)(Position - 1))
If 1 = 2 Then '99 If error
Err01RetriveText: RetriveText = "Position " & Position & " is not found in the text " & InString
End If '99 If error
End Function
IE:
A1 =John Smith
B1 =RetriveText(A1," ",1) 'Result: John
C1 =RetriveText(A1," ",2) 'Result: Smith
Edit: Just realized that you are trying to send by email, are they contacts in Outlook? If so, why not to check them there? Try this function
Public Function ResolveDisplayName(sFromName) As Boolean
'----------------------------------------------------------------------------------
' Procedure : ResolveDisplayNameToSMTP
' Author : Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding.
'-----------------------------------------------------------------------------------
Dim olApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set olApp = CreateObject("Outlook.Application")
Set oRecip = olApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
ResolveDisplayName = True
Else
ResolveDisplayName = False
End If
End Function
I have an excel which serves to record the food you ingest for a specific day and meal. I hav a grid in which each line represent a food you ate, how much sugar it has, etc.
Then i've added an save button to save all the data to a table in another sheet.
This is what i have tried
Public Sub addDataToTable(ByVal strTableName As String, ByRef arrData As Variant)
Dim lLastRow As Long
Dim iHeader As Integer
Dim iCount As Integer
With Worksheets(4).ListObjects(strTableName)
'find the last row of the list
lLastRow = Worksheets(4).ListObjects(strTableName).ListRows.Count
'shift from an extra row if list has header
If .Sort.Header = xlYes Then
iHeader = 1
Else
iHeader = 0
End If
End With
'Cycle the array to add each value
For iCount = LBound(arrData) To UBound(arrData)
**Worksheets(4).Cells(lLastRow + 1, iCount).Value = arrData(iCount)**
Next iCount
End Sub
but i keep getting the same error on the highlighted line:
Application-defined or object-defined error
What i am doing wrong?
Thanks in advance!
You don't say which version of Excel you are using. This is written for 2007/2010 (a different apprach is required for Excel 2003 )
You also don't say how you are calling addDataToTable and what you are passing into arrData.
I'm guessing you are passing a 0 based array. If this is the case (and the Table starts in Column A) then iCount will count from 0 and .Cells(lLastRow + 1, iCount) will try to reference column 0 which is invalid.
You are also not taking advantage of the ListObject. Your code assumes the ListObject1 is located starting at row 1. If this is not the case your code will place the data in the wrong row.
Here's an alternative that utilised the ListObject
Sub MyAdd(ByVal strTableName As String, ByRef arrData As Variant)
Dim Tbl As ListObject
Dim NewRow As ListRow
' Based on OP
' Set Tbl = Worksheets(4).ListObjects(strTableName)
' Or better, get list on any sheet in workbook
Set Tbl = Range(strTableName).ListObject
Set NewRow = Tbl.ListRows.Add(AlwaysInsert:=True)
' Handle Arrays and Ranges
If TypeName(arrData) = "Range" Then
NewRow.Range = arrData.Value
Else
NewRow.Range = arrData
End If
End Sub
Can be called in a variety of ways:
Sub zx()
' Pass a variant array copied from a range
MyAdd "MyTable", [G1:J1].Value
' Pass a range
MyAdd "MyTable", [G1:J1]
' Pass an array
MyAdd "MyTable", Array(1, 2, 3, 4)
End Sub
Tbl.ListRows.Add doesn't work for me and I believe lot others are facing the same problem. I use the following workaround:
'First check if the last row is empty; if not, add a row
If table.ListRows.count > 0 Then
Set lastRow = table.ListRows(table.ListRows.count).Range
For col = 1 To lastRow.Columns.count
If Trim(CStr(lastRow.Cells(1, col).Value)) <> "" Then
lastRow.Cells(1, col).EntireRow.Insert
'Cut last row and paste to second last
lastRow.Cut Destination:=table.ListRows(table.ListRows.count - 1).Range
Exit For
End If
Next col
End If
'Populate last row with the form data
Set lastRow = table.ListRows(table.ListRows.count).Range
Range("E7:E10").Copy
lastRow.PasteSpecial Transpose:=True
Range("E7").Select
Application.CutCopyMode = False
Hope it helps someone out there.
I had the same error message and after lots of trial and error found out that it was caused by an advanced filter which was set on the ListObject.
After clearing the advanced filter .listrows.add worked fine again.
To clear the filter I use this - no idea how one could clear the filter only for the specific listobject instead of the complete worksheet.
Worksheets("mysheet").ShowAllData
I actually just found that if you want to add multiple rows below the selection in your table
Selection.ListObject.ListRows.Add AlwaysInsert:=True works really well. I just duplicated the code five times to add five rows to my table
I had the same problem before and i fixed it by creating the same table in a new sheet and deleting all the name ranges associated to the table, i believe whene you're using listobjects you're not alowed to have name ranges contained within your table hope that helps thanks
Ran into this issue today (Excel crashes on adding rows using .ListRows.Add).
After reading this post and checking my table, I realized the calculations of the formula's in some of the cells in the row depend on a value in other cells.
In my case of cells in a higher column AND even cells with a formula!
The solution was to fill the new added row from back to front, so calculations would not go wrong.
Excel normally can deal with formula's in different cells, but it seems adding a row in a table kicks of a recalculation in order of the columns (A,B,C,etc..).
Hope this helps clearing issues with .ListRows.Add
As using ListRow.Add can be a huge bottle neck, we should only use it if it can’t be avoided.
If performance is important to you, use this function here to resize the table, which is quite faster than adding rows the recommended way.
Be aware that this will overwrite data below your table if there is any!
This function is based on the accepted answer of Chris Neilsen
Public Sub AddRowToTable(ByRef tableName As String, ByRef data As Variant)
Dim tableLO As ListObject
Dim tableRange As Range
Dim newRow As Range
Set tableLO = Range(tableName).ListObject
tableLO.AutoFilter.ShowAllData
If (tableLO.ListRows.Count = 0) Then
Set newRow = tableLO.ListRows.Add(AlwaysInsert:=True).Range
Else
Set tableRange = tableLO.Range
tableLO.Resize tableRange.Resize(tableRange.Rows.Count + 1, tableRange.Columns.Count)
Set newRow = tableLO.ListRows(tableLO.ListRows.Count).Range
End If
If TypeName(data) = "Range" Then
newRow = data.Value
Else
newRow = data
End If
End Sub
Just delete the table and create a new table with a different name. Also Don't delete entire row for that table. It seems when entire row containing table row is delete it damages the DataBodyRange is damaged