I am getting a type mismatch error in VBA and I am not sure why.
The purpose of this macro is to go through a column in an Excel spreadsheet and add all the emails to an array. After each email is added to the first array, it's also supposed to added to a second array but split into two pieces at the # symbol in order to separate name from domain. Like so: person#gmail.com to person and gmail.com.
The problem that I'm getting is that when it gets to the point where it's supposed to split the email, it throws a Type Mismatch error.
Specifically this part:
strDomain = Split(strText, "#")
Here is the complete code:
Sub addContactListEmails()
Dim strEmailList() As String 'Array of emails
Dim blDimensioned As Boolean 'Is the array dimensioned?
Dim strText As String 'To temporarily hold names
Dim lngPosition As Long 'Counting
Dim strDomainList() As String
Dim strDomain As String
Dim dlDimensioned As Boolean
Dim strEmailDomain As String
Dim i As Integer
Dim countRows As Long
'countRows = Columns("E:E").SpecialCells(xlVisible).Rows.Count
countRows = Range("E:E").CurrentRegion.Rows.Count
MsgBox "The number of rows is " & countRows
'The array has not yet been dimensioned:
blDimensioned = False
Dim counter As Long
Do While counter < countRows
counter = counter + 1
' Set the string to the content of the cell
strText = Cells(counter, 5).Value
If strText <> "" Then
'Has the array been dimensioned?
If blDimensioned = True Then
'Yes, so extend the array one element large than its current upper bound.
'Without the "Preserve" keyword below, the previous elements in our array would be erased with the resizing
ReDim Preserve strEmailList(0 To UBound(strEmailList) + 1) As String
Else
'No, so dimension it and flag it as dimensioned.
ReDim strEmailList(0 To 0) As String
blDimensioned = True
End If
'Add the email to the last element in the array.
strEmailList(UBound(strEmailList)) = strText
'Also add the email to the separation array
strDomain = Split(strText, "#")
If strDomain <> "" Then
If dlDimensioned = True Then
ReDim Preserve strDomainList(0 To UBound(strDomainList) + 1) As String
Else
ReDim strDomainList(0 To 0) As String
dlDimensioned = True
End If
strDomainList(UBound(strDomainList)) = strDomain
End If
End If
Loop
'Display email addresses, TESTING ONLY!
For lngPosition = LBound(strEmailList) To UBound(strEmailList)
MsgBox strEmailList(lngPosition)
Next lngPosition
For i = LBound(strDomainList) To UBound(strDomainList)
MsgBox strDomainList(strDomain)
Next
'Erase array
'Erase strEmailList
End Sub
ReDiming arrays is a big hassle. Welcome to the world of collections and Dictionarys. Collection objects are always accessible. Dictionaries require a reference to Microsoft Scripting Runtime (Tools>References>scroll down to find that text and check the box> OK). They dynamically change size for you, you can add, remove items very easily compared to arrays, and Dictionaries especially allow you to organize your data in more logical ways.
In the below code I used a dictionary there the key is the domain (obtained with the split function). Each value for a key is a collection of email addresses with that domain.
Put a break point on End Sub and look at the contents of each of these objects in your locals window. I think you'll see they make more sense and are easier in general.
Option Explicit
Function AllEmails() As Dictionary
Dim emailListCollection As Collection
Set emailListCollection = New Collection 'you're going to like collections way better than arrays
Dim DomainEmailDictionary As Dictionary
Set DomainEmailDictionary = New Dictionary 'key value pairing. key is the domain. value is a collection of emails in that domain
Dim emailParts() As String
Dim countRows As Long
Dim EmailAddress As String
Dim strDomain As String
'countRows = Columns("E:E").SpecialCells(xlVisible).Rows.Count
Dim sht As Worksheet 'always declare your sheets!
Set sht = Sheets("Sheet1")
countRows = sht.Range("E2").End(xlDown).Row
Dim counter As Long
Do While counter < countRows
counter = counter + 1
EmailAddress = Trim(sht.Cells(counter, 5))
If EmailAddress <> "" Then
emailParts = Split(EmailAddress, "#")
If UBound(emailParts) > 0 Then
strDomain = emailParts(1)
End If
If Not DomainEmailDictionary.Exists(strDomain) Then
'if you have not already encountered this domain
DomainEmailDictionary.Add strDomain, New Collection
End If
'Add the email to the dictionary of emails organized by domain
DomainEmailDictionary(strDomain).Add EmailAddress
'Add the email to the collection of only addresses
emailListCollection.Add EmailAddress
End If
Loop
Set AllEmails = DomainEmailDictionary
End Function
and use it with
Sub RemoveUnwantedEmails()
Dim allemailsDic As Dictionary, doNotCallSheet As Worksheet, emailsSheet As Worksheet
Set doNotCallSheet = Sheets("DoNotCallList")
Set emailsSheet = Sheets("Sheet1")
Set allemailsDic = AllEmails
Dim domain As Variant, EmailAddress As Variant
Dim foundDoNotCallDomains As Range, emailAddressesToRemove As Range
For Each domain In allemailsDic.Keys
Set foundDoNotCallDomains = doNotCallSheet.Range("A:A").Find(domain)
If Not foundDoNotCallDomains Is Nothing Then
Debug.Print "domain found"
'do your removal
For Each EmailAddress In allemailsDic(domain)
Set emailAddressesToRemove = emailsSheet.Range("E:E").Find(EmailAddress)
If Not emailAddressesToRemove Is Nothing Then
emailAddressesToRemove = ""
End If
Next EmailAddress
End If
Next domain
End Sub
strDomain must store array of the split text, therefore,
Dim strDomain As Variant
Afterwards, strDomain should be referenced by index, if operations with certain fragments will be made:
If strDomain(i) <> "" Then
The split function returns an array of strings based on the provided separator.
In your if you are sure that the original string is an email, with just one "#" in it then you can safely use the below code:
strDomain = Split(strText, "#")(1)
This will get you the part after "#" which is what you are looking for.
Split returns an array:
Dim mailComp() As String
[...]
mailComp = Split(strText, "#")
strDomain = mailComp(1)
Try strDomain = Split(strText,"#")(1) to get the right hand side of the split where (0) would be the left. And of course works with more than 2 splits as well. You could dim you string variable as an array strDomain() and then Split(strText,"#") will place all the seperated text into the array.
Related
I am currently working on an Access Database and I am trying to create a string of selected items in a multi-select listbox separated by commas (ex. Option 1, Option 3, Option 5). I have been able to get the program to create a list, but it is listing Integers (1,3,5) instead of the text I wrote as the primary key for the data I am using in the listbox. I have tried changing my commands as Variant instead of Integer, but it is still listing 0-based numbers.
Does anyone know a solution to this problem or a code that creates the string out of text instead of integers?
Thank You!
This is the code I have currently (OptionL is the name of my list box)
Function LbxItems() As String
'Returns a list of items in the listbox
Dim lbx As ListBox
Dim varItems As Variant
Dim varItem As Variant
Dim strReturn As String
strReturn = ""
Set lbx = Me!OptionL
varItems = lbx.ItemsSelected.Count
If varItems > 0 Then
For varItem = 0 To varItems - 1
If varItem = 0 Then
strReturn = CStr(lbx.ItemsSelected(varItem))
Else
strReturn = strReturn & "," &
CStr(lbx.ItemsSelected(varItem))
End If
Next
End If
Set lbx = Nothing
LbxItems = strReturn
End Function
I was able to use the code from the link HansUp recommended to solve the problem. (https://stackoverflow.com/a/19353316/77335) Thank you all so much!
.ItemsSelected(<some number>) does not give you what I think you're expecting. It does not give you the value from any column within that selected row.
Use ItemData if you want the value contained in the Bound Column of a selected row. So you could make changes like this to your existing code:
'strReturn = CStr(lbx.ItemsSelected(varItem))
strReturn = CStr(lbx.ItemData(lbx.ItemsSelected(varItem)))
However I would switch to a simpler approach like this:
Public Function LbxItems() As String
Dim strReturn As String
Dim varItem As Variant
With Me.OptionL
For Each varItem In .ItemsSelected
strReturn = strReturn & "," & .ItemData(varItem)
Next
End With
If Len(strReturn) > 0 Then
strReturn = Mid(strReturn, 2) ' discard leading comma
End If
LbxItems = strReturn
End Function
Context:
I have several lists in my sheet (1 column wide, 1-10 rows long). When I right click a cell in these lists, I can do several options, that all work well. I have given a name to the cell at the top of each of these lists (ex. Cell A1 has been given the name cell_1, B10 is names cell_2, etc).
I would like to know if the cell I am right clicking on is the one at the top of the list; is it named "cell_(number)"? If it is not, it checks the cell on top of that one. Does it have a name that starts with "cell_"? If not, check the one on top, etc. Until I can figure out the user clicked on an element of WHICH list.
TL;DR The actual question
I can use ActiveCell.Address, which gives me something like "A1" whether or not I have assigned a name to that cell. ActiveCell.Name gives "Sheet1!A1", so it's not much better. Any idea how to get it to return the name I have assigned instead?
Create a UDF to test the application names, it's less efficient but contains error handling within the function itself:
Sub SO()
'// Example how to call function
Debug.Print GetCellName(Range("A1"))
End Sub
Function GetCellName(myCell As Excel.Range) As Variant
Dim nameCheck As Variant
For Each nameCheck In Application.Names
If Replace(Replace(Replace(nameCheck, "=", ""), "'", ""), "!", "") = _
CStr(myCell.Parent.Name & myCell.Address) Then
GetCellName = CStr(nameCheck.Name)
Exit Function
End If
Next
GetCellName = CVErr(Excel.xlErrName)
End Function
Note you can also use this function in a worksheet cell like so:
=GetCellName(A1)
Perhaps this would work. This function returns the names assigned to a cell (or bigger range for that matter). If there's more than one name, it returns it as an array for array formula...or the user can supply an index to return only the desired name position
Public Function CellIsInRangeNames(sheetname As String, checkRange As Range, Optional itemNumber As Variant) As Variant
Dim oNM As Name
Dim oSht As Worksheet
Dim isect As Range
Dim namesCollection() As Variant
Set oSht = Worksheets(sheetname)
Dim i As Integer
i = -1
For Each oNM In oSht.Names
Set isect = Application.Intersect(Range(oNM.Name), checkRange)
If Not isect Is Nothing Then
i = i + 1
ReDim Preserve namesCollection(0 To i)
namesCollection(i) = CStr(oNM.Name)
End If
Next oNM
If i = -1 Then
'didn't find any
CellIsInRangeNames = xlErrName
ElseIf Not IsMissing(itemNumber) Then
'user wanted this instance only
If (itemNumber - 1 > UBound(namesCollection)) Or (itemNumber - 1 < LBound(namesCollection)) Then
CellIsInRangeNames = xlErrValue
Else
CellIsInRangeNames = namesCollection(itemNumber - 1)
End If
Else 'here's the list as an array
CellIsInRangeNames = namesCollection
End If
End Function
I have written the following function to read all unique values from cells in a range and create a comma separated string from them? Is there a better, simpler way to do this?
Private Sub CsvUniqueValues(r As Excel.Range)
Dim c As Excel.Range
Dim s As String = ""
For Each c In r.Cells
If ExcelApp.WorksheetFunction.CountIf(r, c.Value) = 1 Then
s = s & ","
End If
Next
If s.Length > 0 Then
s = s.Substring(0, s.Length - 1)
End If
End Sub
You could use LINQ to get a list of only the unique values, like this:
Dim uniqueValues As IEnumerable = r.Cells.Where(Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
Then, you could use LINQ to convert all of those unique values to strings:
Dim uniqueStrings As IEnumerable(Of String) = uniqueValues.Select(Of String)(Function(x) x.ToString())
Then you can use LINQ to convert the resulting list to an array:
Dim uniqueArray() As String = uniqueStrings.ToArray()
Then, you could use the String.Join method to combine them into a single CSV string:
Dim csv As String = String.Join(",", uniqueArray)
You could, of course, do all of this in a single command, like this:
Dim csv As String = String.Join(",",
r.Cells.Where(Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
.Select(Of String)(Function(x) x.ToString())
.ToArray())
The question, though, is whether or not you would call that "easier". LINQ is useful because it makes code easier to to read and write, but when it's taken too far, it can become less readable, thereby defeating the purpose of using it. At the very least, to make your code more clear, I would move the first part into a named function so it's more self-documenting:
Public Function GetUniqueCellValuesAsString(r As Excel.Range) As IEnumerable(Of String)
Return r.Cells.Where(
Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
.Select(Of String)(Function(x) x.ToString())
End Function
Then you could just build the CSV string like this:
Dim csv As String = String.Join(",", GetUniqueCellValuesAsString(r).ToArray())
I would make use of the collection object. Since collections can only contain unique values, trying to add all of your input data to a collection will result in an array of unique values. The following modification lets CsvUniqueValues return a comma separated string from the values in any given range.
'Test function and return result in MsgBox
Sub ReturnUnique()
MsgBox CsvUniqueValues(Selection)
End Sub
'Function will return csv-string from input range
Function CsvUniqueValues(r As Range) As String
Dim Cell As Range
Dim i As Integer
Dim DistCol As New Collection
Dim s As String
'Add all distinct values to collection
On Error Resume Next
For Each Cell In r
DistCol.Add Cell.Value, Cell.Value
Next Cell
On Error GoTo 0
'Write collection to comma seperated list
For i = 1 To DistCol.Count
s = s & DistCol.Item(i) & "; "
Next i
s = Left(s, Len(s) - 2)
CsvUniqueValues = s
End Function
The procedure below worked fine for me for a while. However, now the data has changed somewhat. The data is names and they are formatted as Last Name, First Name. Unfortunately, my procedure below was formatted to delimit by comma so what is doing is Last name First Name. I do not want to do that, I would like to keep it as original. How can I change the procedure below to do just that?
Dim xlRng As Excel.Range
Dim strRngArr As String
Dim strChkRange As String
Try
xlWB = CType(Globals.ThisWorkbook.Application.ActiveWorkbook, Excel.Workbook)
xlWS = DirectCast(xlWB.Sheets("allPositionsAnnualized"), Excel.Worksheet)
xlRng = DirectCast(xlWS.Range("B6", xlWS.Range("B6").End(Excel.XlDirection.xlDown)), Excel.Range)
strRngArr = String.Empty
strChkRange = CStr(xlWS.Range("B6").Value)
If (String.IsNullOrEmpty(strChkRange)) Then
cmbSelectPosition.Enabled = False
Else
'Build a string array delimited by commas
For i As Integer = 1 To xlRng.Rows.Count
Dim xlRngCell As Excel.Range = DirectCast(xlRng.Rows(i), Excel.Range)
strRngArr &= DirectCast(xlRngCell.Value.ToString, String) & ","
Next
strRngArr = strRngArr.Remove(strRngArr.Length - 1, 1)
cmbSelectPosition.Items.AddRange(strRngArr.Split(","c))
xlRng = Nothing
xlWS = Nothing
End If
Catch ex As Exception
MsgBox("There no positions available to select", CType(vbOKOnly, MsgBoxStyle), "Empty Selection")
End Try
I tried changing the two lines to:
strRngArr &= DirectCast(xlRngCell.Value.ToString, String)
and
cmbSelectPosition.Items.Add(strRngArr.ToString)
Which should have worked, but instead I only got the first item of my array and it was formatted as Last Name, First NameLastName.
From your comments, I understand that what you want is to replace the loop and the line where the Combobox is being populated with this:
For i As Integer = 1 To xlRng.Rows.Count
cmbSelectPosition.Items.Add(DirectCast(xlRng.Rows(i), Excel.Range).Value)
Next
I would like to know what I'm doing wrong...
I have a word document open (in word 2010) with three tables in it. I wanted to test basic table extraction in VBA and followed the instructions http://msdn.microsoft.com/en-us/library/office/aa537149(v=office.11).aspx.
Sub ExtractTableData()
Dim doc As Word.Document
Dim tbl As Word.Table
Dim rng As Word.Range
Dim sData As String
Dim aData1() As String
Dim aData2() As String
Dim aDataAll() As String
Dim nrRecs As Long
Dim nrFields As Long
Dim lRecs As Long
Dim lFields As Long
Set doc = ActiveDocument
Set tbl = doc.Tables(1)
Set rng = tbl.ConvertToText(Separator:=vbTab, _
NestedTables:=False)
' Pick up the delimited text into and put it into a string variable.
sData = rng.Text
' Restore the original table.
doc.Undo
' Strip off last paragraph mark.
sData = Mid(sData, 1, Len(sData) - 1)
' Break up each table row into an array element.
aData1() = Split(sData, vbCr)
nrRecs = UBound(aData1())
' The messagebox below is for debugging purposes and tells you
' how many rows are in the table. It is commented out but can
' be used simply by uncommenting it.
'MsgBox "The table contained " & nrRecs + 1 & " rows"
'Process each row to break down the field information
'into another array.
For lRecs = LBound(aData1()) To nrRecs
aData2() = Split(aData1(lRecs), vbTab)
' We need to do this only once!
If lRecs = LBound(aData1()) Then
nrFields = UBound(aData2())
ReDim Preserve aDataAll(nrRecs, nrFields)
End If
' Now bring the row and field information together
' in a single, two-dimensional array.
For lFields = LBound(aData2()) To nrFields
aDataAll(lRecs, lFields) = aData2(j)
Next
Next
End Sub
I'm getting an error at this line: ReDim Preserve aDataAll(nrRecs, nrFields), which is due to "nrFields" being set to a negative value (-1)...
No idea how the upper bound of the array is a negative value... Any help on this would be much appreciated.
I figured it out - I was trying to extract a nested table. I had to cycle through all sub-tables and extract individually. Also, I had to search for and remove ^p before extraction to retain table structure.
After I had figured it out, I noticed that the MS code sample had an error: aData2(j) should actually be aData2(lFields).
Hope this helps some other newbie!
If UBound is -1 and LBound = 0, the array is empty. You can generate an empty array as follows:
Dim EmptyArray() As String
Dim s As String
EmptyArray = Split("")
Debug.Print (UBound(EmptyArray)) ' displays -1
Debug.Print (LBound(EmptyArray)) ' displays 0
In your case I suspect you need to skip the processing if the array is empty:
aData1 = Split(...)
If (UBound(aData1) < LBound(aData1) Then
' UBound is -1 and LBound is 0, array is empty, nothing to do
Else
' Array is non-empty, do your stuff
End If
Although quite bizarre, it is possible for VARIANT SAFEARRAY to have negative lower and upper bound values for any of the dimensions. The array extent is LBound(,dimension) to UBound(,dimension).
What must be true is UBound >= LBound.
To get the array size, use UBound - LBound + 1.
It used to be convention to set the lower bound using an Option Base statement at the top of VBA code although, of course, that didn't affect arrays being returned by 3rd party libraries. Most folk used to use 1 as the lower bound.