So I have 10,000+ Rows of Horrible-unformatted-semi-legible-mumbo-jumbo. I have posted my formulas below. I will run out of space in the formula line shortly, and it's not a very efficient method.
The data looks like this:
SCHMIDT,|JOHN|JACOB|JINGLE-HEIMER|PO|BOX|98765|1234|OCTAVIAN|ST|N|100|MILE|HOUSE|
JIMBOB,|JOEY|JAN|PO|BOX|-|98765|1234|MERCER|RD|E|VANCOUVER|
HEISENBERG,|RR|1|-|98765|1234|FRANKLIN|AVE|S|NORTH|VANCOUVER|
MAN,|HE|98765|1234|SKELETOR|PL|W|100|POCO|
RINGO,|JULIUS|CHARLES|98765|1234|SKELETOR|CRES|NE|100|POCO|
BAJINGO,|DOCTOR|SCRUBS|98765|1234|HOSPITAL|RD|NW|100|EAST|VANCOUVER|
What you see does not exactly always appear in the order that it is in; for example "PO BOX" is absent/present, or at the beginning or the middle or the end of the line. Not all Address_Lines have a Suite number, and not all Suite-Address_Line have a "-" separating the two.
At this point, I want to extract the Direction (N,E,S,W,NE,NW,SE,SW) if any, and the Address_line Suffix (Rd, St, Cres, etc.).
These are my formulas:
Line Suffix =IF(ISNUMBER(SEARCH("|ST|",A2)),"ST",IF(ISNUMBER(SEARCH("|RD|",A2)),"RD",IF(ISNUMBER(SEARCH("|AVE|",A2)),"AVE",IF(ISNUMBER(SEARCH("|PL|",A2)),"PL"))))
Direction =IF(ISNUMBER(SEARCH("|N|",A2)),"N",IF(ISNUMBER(SEARCH("|E|",A2)),"E",IF(ISNUMBER(SEARCH("|S|",A2)),"S",IF(ISNUMBER(SEARCH("|W|",A2)),"W"))))
Can I please get some help rewriting these formulas as two separate functions, in VBA?
My thinking is that I call Search() using a CASE function for the Search_Text on a given cell? I just have no idea to go about this.
I would like to be able to call this function on demand by typing it in a cell on the spreadsheet, by referring to the raw string.
Thanks!
Function FOne(v As Variant) As String
Dim vSearch As Variant, c As Variant
vSearch = Array("|ST|", "|RD|", "|AVE|", "|PL|")
For Each c In vSearch
If InStr(1, v, c) Then
FOne = Mid(c, 2, Len(c) - 2)
Exit Function
End If
Next c
End Function
and
Function FTwo(v As Variant) As String
Dim vSearch As Variant, c As Variant
vSearch = Array("|N|", "|E|", "|S|", "|W|")
For Each c In vSearch
If InStr(1, v, c) Then
FTwo = Mid(c, 2, Len(c) - 2)
Exit Function
End If
Next c
End Function
Try This code as your base, and take from there.
Main sub takes the string in cell(1,1) and extract the direction and address line to cells(1,2) and (1,3) using searchForText function.
You should be able to modify it to fit according to your needs, if not let me know.
Sub Main()
Dim values As Variant
values = Array("|N|", "|E|", "|W|", "|S|", "|NE|", "|NW|", "|SE|", "|SW|")
Cells(1, 2).Value = SearchForText(values)
values = Array("RD", "ST", "CRES") 'fill in the rest of optional values
Cells(1, 3).Value = SearchForText(values)
End Sub
Function SearchForText(values As Variant) As String
Dim line As String
Dim i As Long
Dim j As Integer, k As Integer
line = Cells(1, 1).Value
For k = 0 To UBound(values)
For j = Len(line) To Len(values(k)) + 1 Step -1
If Mid(line, j - Len(values(k)), Len(values(k))) = values(k) Then
GoTo result
End If
Next j
Next k
result:
values(k) = Left(values(k), Len(values(k)) - 1) 'remove vertical lines
values(k) = Right(values(k), Len(values(k)) - 1)
SearchForText = values(k)
End Function
Related
I'm trying to check whether the main string contains the entire substring, even if there are interruptions.
For example:
main string = 12ab34cd,
substring = 1234d
should return a positive, since 1234d is entirely contained in my main string, even though there are extra characters.
Since InStr doesn't take wildcards, I wrote my own VBA using the mid function, which works well if there are extra characters at the start/end, but not with extra characters in the middle.
In the above example, the function I wrote
works if the main string is ab1234dc,
but not if it's 12ab34cd.
Is there a way to accomplish what I'm trying to do using VBA?
Note Both of the methods below are case sensitive. To make them case insensitive, you can either use Ucase (or Lcase) to create phrases with the same case, or you can prefix the routine with the Option Compare Text statement.
Although this can be done with regular expressions, here's a method using Mid and Instr
Option Explicit
Function ssFind(findStr, mainStr) As Boolean
Dim I As Long, J As Long
I = 1: J = 1
Do Until I > Len(findStr)
J = InStr(J, mainStr, Mid(findStr, I, 1))
If J = 0 Then
ssFind = False
Exit Function
End If
I = I + 1: J = J + 1
Loop
ssFind = True
End Function
Actually, you can shorten the code further using Like:
Option Explicit
Function ssFind(findStr, mainStr) As Boolean
Dim I As Long
Dim S As String
For I = 1 To Len(findStr)
S = S & "*" & Mid(findStr, I, 1)
Next I
S = S & "*"
ssFind = mainStr Like S
End Function
Assuming you have 3 columns "SUBSTR","MAIN" and "CHECK" and your "Substring" data range is named "SUBSTR"
Sub check_char()
Dim c As Range
For Each c In Range("SUBSTR")
a = 1
test = ""
For i = 1 To Len(c.Offset(0, 1))
If Mid(c.Offset(0, 1), i, 1) = Mid(c, a, 1) Then
test = test & Mid(c.Offset(0, 1), i, 1)
a = a + 1
End If
Next i
If test = c Then
c.Offset(0, 2) = "MATCH"
Else
c.Offset(0, 2) = "NO MATCH"
End If
Next
End Sub
I am trying to calculate the count of Unique values based on a condition.
For example,
For a value in column B, I am trying to count the Unique values in Column C through VBA.
I know how to do it using Excel formula -
=SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))
that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name
This is my code :
Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))
This is the sample data with the requirement
Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.
I don't know where I am going wrong. Kindly share your thoughts.
You may try something like this...
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
Then you can use it like below...
=GetUniqueCount($A$2:$B$10,C2)
Where A2:B10 is the data range and C2 is the name criteria.
I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:
Sub Unique
dim arr(10) as variant, x as variant
dim arr2() as variant
for x = 1 to 10 ' or whatever
arr(x) = cells(x, 1) ' or whatever
next x
arr2 = UniqueValuesArray(arr)
' now write some code to count the unique values, you get the idea
End Sub
Function UniqueValuesArray(arr As Variant) As Variant()
Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long
arrpos = 0
ReDim uniqueArray(arrpos)
For x = 0 To UBound(arr)
If UBound(Filter(uniqueArray, arr(x))) = -1 Then
ReDim Preserve uniqueArray(arrpos)
uniqueArray(arrpos) = arr(x)
arrpos = arrpos + 1
End If
Next x
UniqueValuesArray = uniqueArray
End Function
Let's say I have the following string within a cell:
E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.
And I want to extract only the title from this. The approach I am considering is to write a script that says "Pull text from this string, but only if it is more than 50 characters long." This way it only returns the title, and not stuff like " Stark, T" and " Martell, P". The code I have so far is:
Sub TitleTest()
Dim txt As String
Dim Output As String
Dim i As Integer
Dim rng As Range
Dim j As Integer
Dim k As Integer
j = 5
Set rng = Range("A" & j) 'text is in cell A5
txt = rng.Value 'txt is string
i = 1
While j <= 10 'there are five references between A5 and A10
k = InStr(i, txt, ".") - InStr(i, txt, ". ") + 1 'k is supposed to be the length of the string returned, but I can't differenciate one "." from the other.
Output = Mid(txt, InStr(i, txt, "."), k)
If Len(Output) < 100 Then
i = i + 1
ElseIf Len(Output) > 10 Then
Output = Mid(txt, InStr(i, txt, "."), InStr(i, txt, ". "))
Range("B5") = Output
j = j + 1
End If
Wend
End Sub
Of course, this would work well if it wasn't two "." I was trying to full information from. Is there a way to write the InStr function in such a way that it won't find the same character twice? Am I going about this in the wrong way?
Thanks in advance,
EDIT: Another approach that might work (if possible), is if I could have one character be " any lower case letter." and ".". Would even this be possible? I can't find any example of how this could be achieved...
Here you go, it works exactly as you wish. Judging from your code I am sure that you can adapt it for your needs quite quickly:
Option Explicit
Sub ExtractTextSub()
Debug.Print ExtractText("E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.")
End Sub
Public Function ExtractText(str_text As String) As String
Dim arr As Variant
Dim l_counter As Long
arr = Split(str_text, ".")
For l_counter = LBound(arr) To UBound(arr)
If Len(arr(l_counter)) > 50 Then
ExtractText = arr(l_counter)
End If
Next l_counter
End Function
Edit: 5 votes in no time made me improve my code a bit :) This would return the longest string, without thinking of the 50 chars. Furthermore, on Error handlaer and a constant for the point. Plus adding a point to the end of the extract.
Option Explicit
Public Const STR_POINT = "."
Sub ExtractTextSub()
Debug.Print ExtractText("E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.")
End Sub
Public Function ExtractText(str_text As String) As String
On Error GoTo ExtractText_Error
Dim arr As Variant
Dim l_counter As Long
Dim str_longest As String
arr = Split(str_text, STR_POINT)
For l_counter = LBound(arr) To UBound(arr)
If Len(arr(l_counter)) > Len(ExtractText) Then
ExtractText = arr(l_counter)
End If
Next l_counter
ExtractText = ExtractText & STR_POINT
On Error GoTo 0
Exit Function
ExtractText_Error:
MsgBox "Error " & Err.Number & Err.Description
End Function
Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.
Here my example of thing that i will use.
On the left side is the patch it will use NAME BASE REVISE to check the version of package.
Can you convert the script here in to VBA code. I will study about it and integrate to my real work:
if (Patch name = Pack name) then **** searching for same Name on patch column to reference for patch base and revise number
if (base(c column) > base(h column)) ***checknumber[cellbycell]
display "yes" in J cell
or if (base(C column) = base(h column)) then
check if revise(D column) > revise(I column)
display "yes" in J cell
else display No
So if you can give me example code ; if you have sometime please explain to me that what each line of code is meaning.
You don't need vba for this
=IF($A2=$G2,IF($C2>$H2,"Yes",IF($C2=$H2,IF($D2>$I2,"Yes","No"),"No")),"No")
That goes in column J
something like this should work:
Option Explicit
Sub variousconditions()
Dim i As Integer, x As Integer
x = 0
For i = 2 To 10
With Excel.ThisWorkbook.ActiveSheet
If .Cells(i, 1) = .Cells(i, 7) Then '****searching for same Name on patch
Select Case .Cells(i, 3) '***checknumber[cellbycell]
Case Is > .Cells(i, 8)
.Cells(i, 10) = "yes"
Case Is = .Cells(i, 8)
If .Cells(i, 4) > .Cells(i, 9) Then
.Cells(i, 10) = "yes"
End If
End Select
End If
End With
Next i
End Sub
I have to re-iterate Siddharth's reference as that will tell you where you need to save this code etc. : http://msdn.microsoft.com/en-us/library/office/ee814737%28v=office.14%29.aspx
Here is a function to compare two dot-notation version numbers which you'd need to paste into a new module in the VBA editor.
Option Explicit
Public Function VersionCompare(CurrentVersion As Range, _
TargetVersion As Range)
Dim result As Integer
result = CompareDotStrings(CurrentVersion.Cells(1, 1).Value, _
TargetVersion.Cells(1, 1).Value)
If result = 1 Then
VersionCompare = True
Else
VersionCompare = False
End If
End Function
Private Function CompareDotStrings(LeftValue As String, _
RightValue As String) _
As Integer
Dim CompareLeft() As String, CompareRight() As String, CompareLength As Integer
CompareLeft = Split(LeftValue, ".")
CompareRight = Split(RightValue, ".")
CompareLength = UBound(CompareLeft)
If UBound(CompareRight) < CompareLength Then CompareLength = UBound(CompareRight)
Dim ElementLeft As Integer, ElementRight As Integer, Comparison As Integer
Dim ElementNumber As Integer
For ElementNumber = 0 To CompareLength
ElementLeft = CInt(CompareLeft(ElementNumber))
ElementRight = CInt(CompareRight(ElementNumber))
Comparison = ElementRight - ElementLeft
If Comparison <> 0 Then
CompareDotStrings = Sgn(Comparison)
Exit Function
End If
Next ElementNumber
CompareDotStrings = 0
End Function
With this you can use =VersionCompare(H2, C2) to compare two version numbers and everything else you want to do (like splitting apart the dashed versions) can be done with formulas in the worksheet.