I'm trying to write a macro in VBA to split a bunch of addresses all in the same format into separate columns. So a street address column, suburb, postcode and state code column. The addresses all follow this format:
123 Fake Street, Suburbia QLD 4123
I wish I could approach this using SQL but I'm trying to keep this function inside an excel workbook where addresses would be central.
My planned approach is to write a for loop which counts the length of column D (where the addresses are stored)...so
For LngRow = 2 To Wksht.Range("D" & Wksht.Rows.Count).End(xlUp).Row
//concate/parse here//
Next
and then it would follow a standard procedure of working backwards where it would separate and write the postcode (4 digits), then the state code (an array of state codes), then the suburb (the string between the state code and the delimiting comma after the street address), and finally the street address which is whatever string is remaining after the rest has been removed and rewritten.
I figure working backwards is best since the street address changes whereas the final 3 bits of info are standard.
Is it possible to write such a macro in VBA? Especially given how SQLish it seems.
going by description in the question and assuming that the address format will remain same, here is one approach using Split
Private Sub tt()
Dim strTest As String
Dim arr1
Dim arr2
Dim arr3
Dim StreetAddress As String
Dim Postcode As String
Dim StateCode As String
Dim SubUrb As String
strTest = "123 Fake Street, Suburbia QLD 4123"
arr1 = Split(strTest, ",")
StreetAddress = arr1(0)
arr2 = Split(Trim(arr1(1)), Space(1))
Postcode = arr2(2)
StateCode = arr2(1)
SubUrb = arr2(0)
End Sub
Excel already provides functionality which could achieve what you want. The only requirement is that you save the data to the disc and open it from a existing file. The function is called Workbooks.OpenText, but be aware that it exactly sticks to the given parameters, if you give in the wrong delimiter for example it may give you wrong results in the end or won't open the file correctly splitted.
Workbooks.OpenText "filename", _
DataType:=XlTextParsingType.xlDelimited, Origin:=XlPlatform.xlWindows, _
Space:=True, TextQualifier:=XlTextQualifier.xlTextQualifierNone
This would open a Space seperated Text or CSV file and put the values into many columns, returning an Workbooks Object were further operations can unfold.
The other approach would be to read the Text Linewise and use the VBA String Split to "manually" enter them in corresponding Rows and Columns, which has the advantage that you can manipulate data and strip out characters you don't want to have into the file on the fly. If you want I could give an example for that also.
Related
I have a database with a table called "sales person" which has a combination of names & surnames. On my report it must include the shortened name. Just the most left character of the Names and Surname combined. For example some has just one Name and a Surname, eg. "Pete Sampras". Combined it would show "PS" on my report. Some have more, like "Pete Steff Sampras". Combined it would be "PSS". For my own name is Johan vd Westhuizen. It must now look like "JVW". How would I go about it?
I am a beginner at this, and I'm not sure what to use. I have tried left(), but that's only for the first name
You can split the word in the spaces, and then use the Left() function to get the first character for each word.
In addition, convert it to upper case and trim to remove any spaces (I don't expect any but just in case).
See an example:
Public Function GetInitialsFromName(ByVal fullname As String) As String
'Array to hold the words
Dim arr As Variant
arr = Split(fullname, " ")
Dim initials As String, idx As Integer
'Loop each word, take the 1st letter and append it to the initials.
'Trim and convert to upper case.
For idx = LBound(arr) To UBound(arr)
initials = initials & StrConv(Left(Trim(arr(idx)), 1), vbUpperCase)
Next
GetInitialsFromName = initials
End Function
To call it:
Debug.Print GetInitialsFromName("Johan vd Westhuizen")
Debug.Print GetInitialsFromName("Pete Steff Sampras")
Debug.Print GetInitialsFromName("Pete Sampras")
'JVW
'PSS
'PS
Issue: Query is not able to pull all of the restricted words found in a Long Text Field. It is getting the restricted words from a Table Column of ~100 values.
Sample Data
Table: RecipeTable with Long Text Field: RecipeText
Example Contents of RecipeText Field: Add the rutabaga, leeks, carrots and cabbage to the Instant Pot®. Seal and cook on high pressure for 4 minutes. Quick release the steam. Thinly slice the brisket across the grain and transfer to a serving platter. Arrange the vegetables around the meat, sprinkle with the parsley and serve with the sour cream, horseradish and mustard on the side.
Desired Result:
Want to Compare RecipeText Field against every value in this Short Text Field RestrictedItem in Table: RestrictedTable.
RestrictedTable.RestrictedItem contains 100 values. Let's say it contains 6 for this exercise: milk, bake, spoon, carrots, mustard and steam.
Query would find these matched words in no particular order for a single record: carrots mustard steam
I've tried this: How to find words in a memo field with microsoft access
Result: Finds only 1 of many matches within the Long Text field.
Desired Result: Find ALL matched words extracted within the Long Text string. Duplicates & wildcards are fine. Case sensitive is bad.
Example Tried:
SELECT a.Adjectives, b.Content
FROM A, B
WHERE b.Content Like "*" & a.[adjectives] & "*"
LIKE and after is where I believe the issue is. I've tried using %, parentheses, spaces, etc to no avail.
Mine became this:
SELECT RecipeTable.RecipeText, RestrictedTable.RestrictedItem
FROM RecipeTable, RestrictedTable
WHERE RecipeTable.RecipeText LIKE "*" & RestrictedTable.RestrictedItem & "*";
Notes:
I can find lots of advice to find single words, but not comparing whole table columns to one field.
And, lots of advice to find the first substring or nth position, but I want all of the substrings that match. Not the position & I'm afraid that applying trimming, etc, will slow things down on searching 100 words & trimming for each one.
I am fine making this a calculated field on my form that holds the RecipeText field.
Also fine with making a button that would launch a query to compare the RecipeText field with the RestrictedTable.RestrictedItem List & fill in an empty field RestrictedFound on the same form.
The code below are two approaches to find all restricted words that are in a memo field. While this could all be done programmatically without staging/work tables I would recommend using a temporary or permanent table to extract the words from the memo field via the split function in VBA (after accounting for punctuation and other data scrubbing).
After splitting the words from the memo field into an array they could then be inserted into a separate table with a foreign key reference to RecipeTable. This could be a temporary table or permanent if needed and could be part of the workflow process. A field like PendingReview could be added to RecipeTable for processing new records then marked as false afterwards so they won't be processed again.
After the words were added to the other table it could be joined to RecipeTable
by foreign key and you should have all matches of restricted words.
Once you have the information you could store the stats and discard the work record from your temporary table or delete the work records until the process is run again.
You could do it all in VBA with a dictionary lookup of the restricted words, i.e., query restricted words table, add to a dictionary then loop through matching each word in the memo field with lower case or case insensitive comparison, but it may take a while.
First Code Snippet Below
(If you want compile time checks then you must Reference the Microsoft Scripting Runtime my path is C:\Windows\SysWOW64\scrrun.dll)
Dim dic as Dictionary
Dim memoField as string
Dim words() as String
Dim matchCnt as Integer
'Other variables I didnt declare
'Code to populate dictionary
'Do Until rstRestricted.EOF
' dic.add LCase$(rst("restrictedWord")), 0
' rstRestricted.MoveNext
'Loop
'rstRestricted.Close
'Set rstRestricted = Nothing
Set rst = New adodb.Recordset
rst.Open "SELECT [MemoField] FROM RecipeTable;"
lngRowCnt = CLng(rst.RecordCount) - 1
For x = 0 to lngRowCnt
memoField = LCase$(Nz(rst("MemoField")))
'Replace punctuation like commas, periods
'memoField = Replace(memoField, ",","")
'Now split after data scrubbed
words = Split(memoField, " ")
intWordCnt = UBound(words)
For z = 0 to intWordCnt
If LenB(words(z)) <> 0 Then
If dic.Exists(words(z) = True Then
matchCnt = dic(words(z))
dic(words(z)) = matchCnt + 1
End If
End If
Next z
Next x
Dim WordKeys() as Variant
Dim y as Integer
Dim restrictedWord as string
Dim wordCnt as Integer
WordKeys = dic.Keys
For y = 0 to UBound(WordKeys) '-1
restrictedWord = CStr(WordKeys(y))
wordCnt = CInt(WordKeys(restrictedWord))
'code to save or display stats
Next y
rst.Close
Set rst = Nothing
Set conn = Nothing
I would just do the split of all words into a working table with the word field indexed then do an aggregate with counts of restricted words.
Second Code Snippet
'Option Explicit
Dim sql as String
Dim memoDelimitedData() as String
'Other variables declared
'Code to open Recordset table for recipe and also code to open
'Work table with adOpenDynamic (SELECT * from WorkTable)
'loop through records to be processed
'Split Field (May need variant instead of array. My Access VBA is rusty)
words = Split(memoField, " ")
intWordCnt = UBound(words)
For x = 0 to intWordCnt
With rstWorkTable
.AddNew
!Word = words(x)
!ForeignKeyIdToRecipeTable = intForeignKeyId
.Update
End With
Next x
Then when you have the work table records added you can join to the RecipeTable and the RestrictedTable.
So build a WorkTable of delimited Words from the memo field. Have the foreign key reference to the recipe table then join the RestrictedTable to the WorkTable by the RestrictedItem.
If needed this could be a query for a make table or a staging table permanent table. etc.
So something like this would then give you matches, of any words in your restricted table:
SELECT RecipeTable.RecipeText, RestrictedTable.RestrictedItem
FROM RecipeTable
INNER JOIN WorkTable ON
RecipeTable.Id = WorkTable.RecipeTableId
INNER JOIN RestrictedTable ON
WorkTable.ForeignKeyIdToRecipeTable = RestrictedTable.RestrictedItem
MS Access Split Function
At that point you could do counts, sums, and other data.
I'm sorry I thought I had example code, but I couldn't find it. I had to do something like this in college many moons ago using VBA and Access (Word Count/Ranking assignment), but I can't find it. Nowadays I'd do this kind of stuff with SQL Server with numbers tables, XML/JSON functionality or the Full Text Searching capability.
Hopefully this may help point you in the right direction if you need to limit your work inside MS Access.
If you're not comfortable with working with ADODB or DAO recordsets you could build a CSV delimited file with the foreign key and the word then import that file into a work table.
In a column with hundreds or even 1-2 thousand strings of approximately 40 characters, with one string per cell and many repeating entries, what is the best way to populate the column to conduct the fastest possible search later? The search should return a row number so that the corresponding row can be deleted.
Is there some way to append metadata or label to a cell/row for faster search? Is there some other mechanism that can identify cells that will make searching easier?
I'm new to VBA, and I want to set out on the best path before I get too far into the project and have to search through thousands of strings.
edit: Someone requested an example cell: The cells will have email addresses in them. I can control the email addresses on the server, so they will roughly be 40 characters long each. They will contain alphanumeric characters only.
Example of a fast way to implement a dictionary lookup
Data is on Sheet1, and starts in column A
The strings are in column B
Option Explicit
Public Sub SearchStrings()
Dim ur As Variant, r As Long, d As Object
Const COL_ID = 2
Set d = CreateObject("Scripting.Dictionary") 'or Reference to Microsof Scripting Runtime
d.CompareMode = TextCompare 'Case insensitive, or "BinaryCompare" otherwise
ur = Sheet1.UsedRange.Columns(COL_ID) 'read strings from column COL_ID into array
For r = LBound(ur) To UBound(ur) 'populate dictionary; Key = string (unique)
If Not IsError(ur(r, 1)) Then d(CStr(ur(r, 1))) = r 'Item = row id
Next
Debug.Print d.Keys()(3) 'prints the string in row 3
Debug.Print d.Items()(3) 'prints the row number of the 3rd string
End Sub
If you want to store string duplicates use this:
If Not IsError(ur(r, 1)) Then d(COL_ID & "-" & r) = CStr(ur(r, 1))
which is Key = Column ID & "-" & row ID (2-5), and Item = String itself
I apologize in advance if this has been answered before, but I couldn't seem to find exactly what I was looking for when I searched.
I'm not too familiar with VB. I was wondering if it was possible to read an entire column of a table in an Access database and put the data into an array using VB?
If you are using Access VBA you can use the Recordset.GetRows method.
This creates a two-dimensional array which matches the design of your recordset, and it takes a single parameter which is the number of rows to retrieve. To retrieve all rows, either get the .RecordCount before populating the array, or put in a number which you know is larger than required.
For example:
Sub ReadIntoArray()
Dim rstName As Recordset
Dim varName As Variant
Set rstName = CurrentDb.OpenRecordset("SELECT FirstName, LastName FROM tblContact")
varName = rstFirstName.GetRows(1000) ' Gets the first 1000 records
' Retrieve the 16th value from the 1st column
Debug.Print varName(0, 15)
' Get the 100th value from the 2nd column
Debug.Print varName(1, 99)
End Sub
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.