I have thousands of addresses in this format:
123 Happy St. Kansas City, MO 64521
9812 Main Street Minneapolis, MN 62154
12 Virgina Ave, Apt 8, Dallas, TX 54334
I want to extract the address, city, state, zip into individual cells (without using VB if possible). I've tried a couple variations of other methods posted, but I can't quite get desired results.
Analyze your problem!
you want to split your address string at the comma
you then want to split the right fragment from (1) at the first blank
ad 1): you get the position of the comma using =FIND(",", A1), and use the result in a =LEFT(...) and a =RIGHT(...) - for the latter you also need the string length (=LEN(...))
B1: =LEFT(A1;FIND(",";A1)-1)
C1: =RIGHT(A1;LEN(A1)-LEN(B1)-2)
Now comes the fun part ... in your 3rd example we mustn't split on the first comma, but on the third comma ... or as a more general rule, we always must split on the last comma .... but how do we find how many commas we have in the string, to feed its position as an additional argument into the =FIND(...) function?
Quick answer: look at Stackoverflow (exactly here) ... very clever ... subtract the length of the string with all commas removed from the original length, and then replace the last occurence of the comma by something else, because =SUBSTITUTE(...) works on occurence, whilst =FIND() only works on position. If you incorporate all this this, you will have
B1: =LEFT(A1;FIND("#";SUBSTITUTE(A1;",";"#"; LEN(A1)-LEN(SUBSTITUTE(A1;",";""))))-1) --> full address
C1: (same as above)
Here we use "#" as a neutral substitution string for the final comma as we asume that no address uses the "#"
ad 2): you apply the above (with blank instead of comma) once again to the right part. You can use the simple first version of the formulae as it's clear you want to split at the first blank
D1: =LEFT(C1;FIND(" ";C1)-1) --> state
E1: =RIGHT(C1;LEN(C1)-LEN(D1)-1) --> ZIP code
This VBA function extracts Zip, State, City, Street1, and Street2 (Suite, Apt, etc.) into separate columns. Would need minor modification to remove commas.
Option Explicit
Function ParseAddress(ByVal varAddress As Variant, ByVal strAddressPart As String) As String
Dim aryAddressTokens() As String
Dim strCity As String
Dim intCtr As Integer
Dim intStreet2Tokens As Integer
Dim strStreet1, strStreet2 As String
If IsMissing(varAddress) Or varAddress = vbNullString Then
ParseAddress = ""
Else
aryAddressTokens = Split(Trim(varAddress), " ")
'
If strAddressPart = "Zip" Then
ParseAddress = aryAddressTokens(UBound(aryAddressTokens))
ElseIf strAddressPart = "State" Then
ParseAddress = UCase(aryAddressTokens(UBound(aryAddressTokens) - 1))
ElseIf strAddressPart = "City" Then
strCity = aryAddressTokens(UBound(aryAddressTokens) - 2)
If Right(strCity, 1) = "," Then strCity = Left(strCity, Len(strCity) - 1)
ParseAddress = strCity
ElseIf strAddressPart = "Street1" Or strAddressPart = "Street2" Then
'Find Street2 if present because Street1 output is dependent on it.
' Assume address never begins with a # or Suite.
intCtr = 1
strStreet2 = ""
intStreet2Tokens = 0
While (intCtr < UBound(aryAddressTokens) - 2) And strStreet2 = ""
If Left(aryAddressTokens(intCtr), 1) = "#" Then
If Len(aryAddressTokens(intCtr)) = 1 Then
strStreet2 = aryAddressTokens(intCtr) & aryAddressTokens(intCtr + 1)
intStreet2Tokens = 2
Else
strStreet2 = aryAddressTokens(intCtr)
intStreet2Tokens = 1
End If
ElseIf Left(aryAddressTokens(intCtr), 5) = "Suite" Then
If Len(aryAddressTokens(intCtr)) = 5 Then
strStreet2 = aryAddressTokens(intCtr) & " " & aryAddressTokens(intCtr + 1)
intStreet2Tokens = 2
Else
strStreet2 = aryAddressTokens(intCtr)
intStreet2Tokens = 1
End If
ElseIf Left(aryAddressTokens(intCtr), 3) = "Apt" Then
strStreet2 = aryAddressTokens(intCtr) & " " & aryAddressTokens(intCtr + 1)
intStreet2Tokens = 2
End If
intCtr = intCtr + 1
Wend
If Not IsEmpty(strStreet2) Then
If Right(strStreet2, 1) = "," Then strStreet2 = Left(strStreet2, Len(strStreet2) - 1)
End If
' Now Street1.
strStreet1 = ""
For intCtr = 0 To UBound(aryAddressTokens) - (3 + intStreet2Tokens)
strStreet1 = strStreet1 & " " & aryAddressTokens(intCtr)
Next
If Right(strStreet1, 1) = "," Then strStreet1 = Left(strStreet1, Len(strStreet1) - 1)
'Assign.
If strAddressPart = "Street1" Then
ParseAddress = Trim(strStreet1)
Else
ParseAddress = Trim(strStreet2)
End If
End If
End If
End Function
Related
I am trying to convert a string, which has a date in US format into UK format.
The following code seems to be hit or miss when it comes to a date that is single digits for both the day and the month:
X = 3
Do While strTimeStamp = 0
If InStr(WS2.Cells(lRow, lCol), "TIMESTAMP") <> 0 Then
strHPCStats = Split(WS2.Cells(lRow, lCol), " ")
'strHPCStats(X) = Mid(strHPCStats(X), 4, 6)
re.Pattern = "^(\d{2})(\d{2})(\d{4})$"
strHPCStats(X) = re.Replace(strHPCStats(X), "$3/$2/$1")
strHPCStats(X) = Format$(strHPCStats(X), "dd/mmm/yyyy")
strTimeStamp = strHPCStats(X)
WS2.Cells(lRow, lCol).EntireRow.Delete
lRow = lRow - 1
Else
WS2.Cells(lRow, lCol).EntireRow.Delete
lRow = lRow - 1
End If
lRow = lRow + 1
Loop
The typical string:
4:19:17 (application) TIMESTAMP 3/13/2022
The string where it is having trouble:
5:36:32 (cameo) TIMESTAMP 4/1/2022
d{2} will look for exactly 2 digits, so if your date has a month (or day) with only 1 digit, the regex doesn't match.
If you want to specify 1 or 2 digits, you can for example use d{1,2}, so the statement would be
e.Pattern = "^(\d{1,2})(\d{1,2})(\d{4})$"
Details: How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
There's no need to use regular expressions, given your expected data.
Just look for two slashes in a space-separated string:
Function us2ukDate(S As String) As Date
Dim v, w, x
v = Split(S, " ")
For Each w In v
If (Len(w) - Len(Replace(w, "/", ""))) = 2 Then
x = Split(w, "/")
us2ukDate = DateSerial(x(2), x(0), x(1))
Exit Function
End If
Next w
End Function
testing example
If, instead of just returning the date, you want to change the format within the string, you could do something like:
Sub convertStrings()
Const d1 = "4:19:17 (application) TIMESTAMP 3/13/2022"
Const d2 = "5:36:32 (cameo) TIMESTAMP 4/1/2022"
Dim sParts
sParts = Split(d1, " ")
sParts(UBound(sParts)) = Format(us2ukDate(sParts(UBound(sParts))), "dd-mmm-yyyy")
Debug.Print Join(sParts, " ")
sParts = Split(d2, " ")
sParts(UBound(sParts)) = Format(us2ukDate(sParts(UBound(sParts))), "dd-mmm-yyyy")
Debug.Print Join(sParts, " ")
End Sub
I have a comma separated lists in cells. All numbers are positive and between 1 and 10.
Example:
if I have in A1: (2,3,5,6), I would like to have missing numbers in B1:(1,4,7,8,9,10).
If A2: (1,10), then I would have in B2:(2,3,4,5,6,7,8,9)
If A3: (7), then I would have in B2:(1,2,3,4,5,6,8,9,10)
I searched for a solution online, but I couldn't find anything similar with comma separated numbers.
I'd be glad if I can have a solution here. Thanks.
Here is a user-defined function that should accomplish this... probably can be optimized.
Public Function MissingNumbers(ByVal numberList As String) As String
Dim temp As String
temp = Replace(numberList, "(", "")
temp = Replace(temp, ")", "")
Dim arr As Variant
arr = Split(temp, ",")
Dim newNumbers As String
newNumbers = "1,2,3,4,5,6,7,8,9,10,"
Dim i As Long
For i = LBound(arr) To UBound(arr)
newNumbers = Replace(newNumbers, arr(i) & ",", "")
Next
newNumbers = "(" & Left$(newNumbers, Len(newNumbers) - 1) & ")"
MissingNumbers = newNumbers
End Function
Just for fun demonstrating how to use negative filtering:
Function MissingList(ByVal numberList As String) As String
Dim given: given = Split(Mid(numberList, 2, Len(numberList) - 2), ",")
Dim series: series = GetSeries() ' i.e. numbers 1..10
Dim i As Long
For i = 0 To UBound(given)
series = Filter(series, given(i), False) ' << negative filtering
Next
MissingList = "(" & Replace(Join(series, ","), "0", "10") & ")"
End Function
As Filter executes a partial search in the 1..10 series, 10 has to be replaced temporarily by a unique 0.
Help function GetSeries()
Function GetSeries()
' Purpose: get numbers 1..10
Const LAST As Long = 10: Const FIRST = 1
Dim tmp: tmp = Application.Transpose(Evaluate("row(" & FIRST & ":" & LAST & ")"))
tmp(LAST) = 0 ' replace 10 by 0 as search item 1 would filter out value 10, too
GetSeries = tmp
End Function
I am working on some software that cleans up data before sending it into another system. The data comes from all around the world and contains a variety of characters that have to be replaced. For example ‘, : ; #
The system that accepts the parsed data has very strict character set. It allows
the letters A to Z (upper case only)
the numerals 0 to 9
the special characters / -. Space < =
The data arrives in Excel spreadsheets so I have written the following code in a visual basic macro.
fhl_str contains the data to be cleansed
fhl_str = Replace(fhl_str, ",", " ")
fhl_str = Replace(fhl_str, "'", " ")
fhl_str = Replace(fhl_str, ":", " ")
fhl_str = Replace(fhl_str, ";", " ")
fhl_str = ucase(fhl_str)
Now, each time a new unwanted character arrives we have to add a new line of code. e.g. fhl_str = Replace(fhl_str, "#", " ")
My question is
Could I reverse the logic so that the macro looks for A to Z and 0 to 9 and deletes anything else. That way my code would be future proof for new unwanted characters.
Thanks
If you want to replace bad characters with a single space:
Sub KeepOnlyTheGood()
Dim i As Long, L As Long, v As String, CH As String
Dim r As Range
For Each r In Selection
t = ""
v = r.Value
L = Len(v)
For i = 1 To L
CH = Mid(v, i, 1)
If CH Like "[0-9A-Z]" Or CH = "/" Or CH = "-" Or CH = "." Or CH = " " Or CH = "<" Or CH = "=" Then
t = t & CH
Else
t = t & " "
End If
Next i
r.Value = t
Next r
End Sub
Here's some VBA that will do it if you find regex difficult to understand. It uses the ASCII code to determine the only characters to allow. If your scope changes you can modify the ASCII numbers in the Case statement.
Public Function RemoveSpecial(s As String) As String
Dim sResult As String
Dim nIndex As Integer
s = UCase$(s)
For nIndex = 1 To Len(s)
Select Case Asc(Mid$(s, nIndex, 1))
Case 65 To 90, 45 To 57, 32, 60 To 61
sResult = sResult & Mid$(s, nIndex, 1)
Case Else
sResult = sResult & " "
End Select
Next
RemoveSpecial = sResult
End Function
Usage:
Debug.Print RemoveSpecial("TeSt<>=.##")
or something like:
Range("A1") = RemoveSpecial("TeSt<>=.##")
ASCII Codes
I have sales report from e-shop and need to calculate cost of goods for each order line. Order line can look like one of these:
2x Lavazza Crema e Aroma 1kg - 1x Lavazza Dolce Caffe Crema 1kg
1x Lavazza Vending Aroma Top 1kg - 1x Arcaffe Roma 1Kg - 1x Kimbo - 100% Arabica Top Flavour
So, what I need Excel to do is to take each product, find its cost with vlookup function from another sheet and then multiply it with amount ordered. The issue is that nr of products ordered can vary from 1 to 10+.
I tried to calculate it with VBA, but the code is not working (I didn´t use multiplying at the moment, I know)
Maybe it is possible to solve this problem with excel formulas?
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, strDelim)
Set lookup_range = Worksheets("Products").Range("B:E")
For i = LBound(larray) To UBound(larray)
skuarray = Split(larray(i), "x ")
skucost = Application.WorksheetFunction.VLookup(UBound(skuarray), lookup_range, 4, False)
cost = cost + skucost
Next i
GoodsCost = cost
End Function
Well, it seems like now the problem is solved. Of course, it works only if make an assumption that dashes(-) are not present in product descriptions. But it can be set up in product list. The other opportunity is to use another delimeter (for example "/"). We can use Ctrl+F to find all combinations like "x -" and replace them with "x /")
Function GoodsCost(str)
Dim answer As Double
Set Products = Worksheets("Products").Range("B:E")
larray = Split(str, " - ")
For i = LBound(larray) To UBound(larray)
sku = Split(larray(i), "x ")
Price = Application.WorksheetFunction.VLookup(sku(1), Products, 4, False) * sku(0)
answer = answer + Price
Next i
GoodsCost = answer
End Function
Below you find a UDF (User Defined Function) which you can use in your worksheet. After installing it in a standard code module (VBE names these like "Module1") you can call it from the worksheet like =CostOfGoods($A2) where A2 is the cell containing and order line as you have described.
Option Explicit
Function CostOfGoods(Cell As Range) As Single
' 15 Jan 2018
Const Delim As String = " - "
Dim Fun As Single ' function return value
Dim Sale As Variant
Dim Sp() As String
Dim i As Long
Dim PriceList As Range
Dim Qty As Single, Price As Single
Dim n As Integer
Sale = Trim(Cell.Value)
If Len(Sale) Then
Sp = Split(Sale, Delim)
Do While i <= UBound(Sp)
If InStr(Sp(i), "x ") = 0 Then
If Not ConcatSale(Sp, i, Delim) Then Exit Do
End If
i = i + 1
Loop
With Worksheets("Products")
i = .Cells(.Rows.Count, "B").End(xlUp).Row
' price list starts in row 2 (change as required)
Set PriceList = Range(.Cells(2, "B"), .Cells(i, "E"))
End With
For i = 0 To UBound(Sp)
Qty = Val(Sp(i))
n = InStr(Sp(i), " ")
Sp(i) = Trim(Mid(Sp(i), n))
On Error Resume Next
Price = Application.VLookup(Sp(i), PriceList, 4, False)
If Err Then
MsgBox "I couldn't find the price for" & vbCr & _
Sp(i) & "." & vbCr & _
"The total cost calculated excludes this item.", _
vbInformation, "Price not found"
Price = 0
End If
Fun = Fun + (Qty * Price)
Next i
End If
CostOfGoods = Fun
End Function
Private Function ConcatSale(Sale() As String, _
i As Long, _
Delim As String) As Boolean
' 15 Jan 2018
Dim Fun As Boolean ' function return value
Dim x As Long, f As Long
x = UBound(Sale)
If (i > 0) And (i <= x) Then
i = i - 1
Sale(i) = Sale(i) & Delim & Sale(i + 1)
For f = i + 1 To x - 1
Sale(f) = Sale(f + 1)
Next f
Fun = True
End If
If Fun Then ReDim Preserve Sale(x - 1)
ConcatSale = Fun
End Function
I have tested this and it works with dashes in product description:
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, " ")
'split the cell contents by space
Set lookup_range = Worksheets("Products").Range("B:E")
'set lookup range
For i = LBound(larray) To UBound(larray) 'loop through array
nextproduct:
LPosition = InStr(larray(i), "x") 'find multiplier "x" in string
If LPosition = Len(larray(i)) Then 'if the last character is x
If Product <> "" Then GoTo lookitup 'lookup product
Quantity = larray(i) 'get quantity
Else
Product = Product & " " & larray(i) 'concatenate array until we get a full product description to lookup with
End If
Next i
lookitup:
If Right(Product, 2) = " -" Then Product = Left(Product, Len(Product) - 2)
If Left(Product, 1) = " " Then Product = Right(Product, Len(Product) - 1)
'above trim the Product description to remove unwanted spaces or dashes
cost = Application.WorksheetFunction.VLookup(Product, lookup_range, 4, False)
Quantity = Replace(Quantity, "x", "")
GoodsCost = cost * Quantity
MsgBox Product & " # Cost: " & GoodsCost
Product = ""
If i < UBound(larray) Then GoTo nextproduct
End Function
I'd use Regular Expressions to solve this. First it finds in the string were the 'delimiters' are by replacing the - with ; detecting only - that are next to a number followed by an x (i.e. a multiplier so ignoring - in product names). It then splits each of these results into a quantity and the product (again using RegEx). It then finds the product in your data and returns the cost of goods. If there is an error, or the product isn't in your data it returns a #Value error to show that there is an issue.
Public Function GoodsCost(str As String) As Double
Dim lookup_range As Range, ProductMatch As Range
Dim v, Match
Dim qty As Long
Dim prod As String
Dim tmp() As String
On Error GoTo err
Set lookup_range = Worksheets("Products").Range("B:E")
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.pattern = "(\s\-\s)(?=[0-9]+x)"
If .test(str) Then
tmp = Split(.Replace(str, ";"), ";")
Else
ReDim tmp(0)
tmp(0) = str
End If
.pattern = "(?:([0-9]+)x\s(.+))"
For Each v In tmp
If .test(v) Then
Set Match = .Execute(v)
qty = Match.Item(0).submatches.Item(0)
prod = Trim(Match.Item(0).submatches.Item(1))
Set ProductMatch = lookup_range.Columns(1).Find(prod)
If Not ProductMatch Is Nothing Then
GoodsCost = GoodsCost + (qty * ProductMatch.Offset(0, 3))
Else
GoodsCost = CVErr(xlErrValue)
End If
End If
Next v
End With
Exit Function
err:
GoodsCost = CVErr(xlErrValue)
End Function
I have a text document full of 9 digit numbers. I need Excel to either read the text (.txt) file or a text cell and add each 9 digit number to each cell in a column.
Example text file:
123456789, 987654321, 213454321 / 987656789, [098752739]
Excel result:
123456789
987654321
213454321
987656789
098752739
Any advice?
You can use the standard Excel feature for importing data from Text file. Ribbon tab Data -> From Text.
From your result, with each cell containing the 9 digit number:
Click Data -> Text to columns
Select "Fixed Width"
You will then need to set break lines between each of your nine
digits
Optional: Click "Next" to format each of the fields
Finally, click "Finish"
You should now see each of the nine digits in a separate column.
Assuming your data is in a single cell, then your task has three parts:
read data from text file
parse each cell
store the results in a column
This code addresses only the second part:
Sub ParseData()
Dim s1 As String
s1 = Range("A1").Text
s1 = Replace(s1, " ", "|")
s1 = Replace(s1, "/", "|")
s1 = Replace(s1, "[", "|")
s1 = Replace(s1, "]", "|")
s1 = Replace(s1, ",", "|")
s1 = CleanUp(s1, "|")
ary = Split(s1, "|")
i = 1
For Each a In ary
Cells(i, 2).NumberFormat = "#"
Cells(i, 2).Value = a
i = i + 1
Next a
End Sub
Public Function CleanUp(sIN As String, sep As String) As String
Dim temp As String, temp2 As String, i As Long, CH As String
temp = sIN
While Left(temp, 1) = sep
temp = Mid(temp, 2)
Wend
While Right(temp, 1) = sep
temp = Mid(temp, 1, Len(temp) - 1)
Wend
temp2 = ""
For i = 1 To Len(temp)
CH = Mid(temp, i, 1)
If temp2 = "" Then
temp2 = CH
ElseIf CH <> sep Then
temp2 = temp2 & CH
ElseIf Right(temp2, 1) <> sep Then
temp2 = temp2 & CH
End If
Next i
CleanUp = temp2
End Function
NOTES:
The code replaces the various field separators with a single pipe. The data is then split using the pipe. The resulting array is then stored in cells: