I am trying to lookup a value and return multiple values (whether it be in the same cell or spread out horizontally pasted in different columns)I have tried the following UDF and continue to get #VALUE as result.
Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String
Dim s As String 'Results placeholder
Dim sTmp As String 'Cell value placeholder
Dim r As Long 'Row
Dim c As Long 'Column
Const strDelimiter = "|||" 'Makes InStr more robust
s = strDelimiter
For r = 1 To lookupRange.Rows.Count
For c = 1 To lookupRange.Columns.Count
If lookupRange.Cells(r, c).Value = lookupValue Then
'I know it's weird to use offset but it works even if the two ranges
'are of different sizes and it's the same way that SUMIF works
sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
s = s & sTmp & strDelimiter
End If
End If
Next
Next
'Now make it look like CSV
s = Replace(s, strDelimiter, ",")
If Left(s, 1) = "," Then s = Mid(s, 2)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
LookupCSVResults = s 'Return the function
End Function
Formula in cell =LookupCSVResults(Lookup Value, Col of Lookup Value, Col of Return Value)
Can anyone help trouble shoot this or have another UDF that will provide similar result? Thanks.
Related
I'm trying to look for values to create a final ticket number for a ticket reconciliation process. This is what should happen:
subroutine looks for a value in cell "Gx"
if it finds a value
pass value to function to strip out letters, convert to a number, pass back to subroutine to place in
cell "Ax"
if there is no value
pass value of "Cx" to function etc.
This loops through the number cells I have in my worksheet based on the number of rows filled in a separate column.
The function works fine by itself in the worksheet, but when I pass it a value from the subroutine column A fills up with the number of the row ie. A37=37, A8=8. I don't think I'm passing the argument correctly to the function, but I'm not certain. Here's the code for the subroutine and the function:
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
'header label
Range("A1").Value = "Final Ticket #"
'set number of rows for loop
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
'check col G for empty, use col C as backup
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
'strip out letters in col G, place in col A
Cells(i, "A").Value = getNumeric("G" & i)
Else
'strip out letters in col C, place in col A
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
stringLength = Len(cellRef)
'loops through each character in a cell to evaluate if number or not
For i = 1 To stringLength
If IsNumeric(Mid(cellRef, i, 1)) Then
Result = Result & Mid(cellRef, i, 1)
End If
Next i
'convert remaining characters to number
getNumeric = CLng(Result)
End Function
What am I missing?
As I understand it, the only thing that is wrong is your Len (cellRef), here you are only passing the range and not his value. See how I did it, I had to specify the spreadsheet, do the same that will work.
Use debug.print to see the outputs of the variables. Write in the code "debug.print XvariableX" and in the immediate check (Ctrl + G) you see the value assigned to the variable. good luck.
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
Range("A1").Value = "Final Ticket #"
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
Cells(i, "A").Value = getNumeric("G" & i)
Else
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
Dim Wrs As String
Wrk = ActiveWorkbook.Name
Workbooks(Wrk).Activate
Wrs = ActiveSheet.Name
stringLength = Len(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef))
For i = 1 To stringLength
If IsNumeric(Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)) Then
Result = Result & Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)
End If
Next i
getNumeric = CLng(Result)
End Function
I have a column containing formulas as "strings", i.e. "=+I11+I192+I245+I280"
I need to replace the cells (I11, I192,I245andI280`) ID with the content (strings) contained in the cells themselves.
Example:
Cell X --> "=+I11+I192+I245+I280"
Cell I11 = 'A'
Cell I192 = 'B'
Cell I245 = 'C'
Cell I280 = 'D'
The formula should generate "=+A+B+C+D".
This?
="=+" & I11 &"+" & I192 &"+" & I245 & "+" & I280
Well, how about :
=I11 & I192 & I245 & I280
Or you can include spaces
=I11 & " " & I192
But straight quotes - my phone is being funny...
The formula should generate --> "=+A+B+C+D"
Try,
="=+"&textjoin("+", true, I11, I192, I245, I280)
Don't know what you will be doing with empty cells so here is draft
Public Sub test()
[I11] = "A": [I192] = "B": [I245] = "C": [I280] = "D"
Debug.Print ConvertedString("=+I11+I192+I245+I280")
End Sub
Public Function ConvertedString(ByVal inputString As String) As Variant
Dim arr() As String, i As Long
On Error GoTo errHand
If Not InStr(inputString, Chr$(43)) > 0 Then
ConvertedString = CVErr(xlErrNA)
Exit Function
End If
arr = Split(inputString, Chr$(43))
For i = 1 To UBound(arr)
arr(i) = Range(arr(i))
Next i
ConvertedString = Join(arr, Chr$(43))
Exit Function
errHand:
ConvertedString = CVErr(xlErrNA)
End Function
I think you mean something like
=INDIRECT(I11,TRUE)+INDIRECT(I192,TRUE)+INDIRECT(I245,TRUE)+INDIRECT(I280,TRUE)
but please note that Indirect is a volatile function, and can slow your calculations down if used extensively.
Using VBA (with only single delimiter):
Function ReplaceAddr(sInput As String, Optional sDelimiter As String = "+") As String
Dim sArr
Dim i As Long
sArr = Split(sInput, sDelimiter)
For i = 1 To UBound(sArr)
sArr = Range(sArr(i))
Next i
ReplaceAddr = Join(sArr, sDelimiter)
End Function
From OP's comment:
The problem is that formulas changes, so I can't only change manually. The one I gave you is only an example, but I have so many different ones with all math operators.
You can try finding cell addresses with regular expression and replace with cell's value:
Function ReplaceAddr2(sInput As String) As String
Dim oRegEx As Object
Dim oMatches As Object
Dim i As Long, lStart As Long, lLength As Long
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "[A-Za-z]{1,3}\d{1,7}"
oRegEx.Global = True
oRegEx.MultiLine = True
Set oMatches = oRegEx.Execute(sInput)
lStart = 0
For i = 0 To oMatches.Count - 1
lLength = oMatches(i).FirstIndex - lStart
ReplaceAddr2 = ReplaceAddr2 & Mid$(sInput, lStart + 1, lLength) & Range(oMatches(i).Value)
lStart = lStart + lLength + oMatches(i).length
Next
ReplaceAddr2 = ReplaceAddr2 & Mid(sInput, lStart + 1, Len(sInput) - lStart)
End Function
Pattern is 1-3 letters followed by 1-7 digits.
Both functions are not volatile - will be recalculated only when input string changes, but not when cells addressed there change. Adding this line:
Application.Volatile True
will make it recalculate on every change, but it may affect performance.
Ok so I have two columns of data as follows
Personalisation Max Char | Personaisation Field
1x15x25 | Initial, Name, Date
Previously I was using the following vba function (As excel16 has no TEXTJOIN)
Function TEXTJOIN(delim As String, skipblank As Boolean, arr)
Dim d As Long
Dim c As Long
Dim arr2()
Dim t As Long, y As Long
t = -1
y = -1
If TypeName(arr) = "Range" Then
arr2 = arr.Value
Else
arr2 = arr
End If
On Error Resume Next
t = UBound(arr2, 2)
y = UBound(arr2, 1)
On Error GoTo 0
If t >= 0 And y >= 0 Then
For c = LBound(arr2, 1) To UBound(arr2, 1)
For d = LBound(arr2, 1) To UBound(arr2, 2)
If arr2(c, d) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c, d) & delim
End If
Next d
Next c
Else
For c = LBound(arr2) To UBound(arr2)
If arr2(c) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c) & delim
End If
Next c
End If
TEXTJOIN = Left(TEXTJOIN, Len(TEXTJOIN) - Len(delim))
End Function
This would change 1x15x25 into 1-1, 2-15, 3-25using the following formula
{=TEXTJOIN(", ",TRUE,ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) & " - " & TRIM(MID(SUBSTITUTE(A1,"x",REPT(" ",999)),(ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) -1)*999+1,999)))}
Due to the fact, my original method was not specific enough I've been forced to go back to the drawing board.
From the Above, I am wanting to produce the following.
1-2-Initial, 2-15-Name, 3-25-Date
I am a developer but not in visual basic and the worst part Is I know what I would do with a database and PHP just don't have enough knowledge to transfer that to excel.
So I need to either by formula or function
Take 2 Columns and split by a delimiter
Then count the entries on each (Maybe only one)
Then for each in the range create a new string adding the count-col1-col2
I cannot change the data as its given by the supplier
I have a basic understanding of VBA so explain don't belittle
UPDATED (DATA SNAPSHOTS)
This Example uses the formula above a little-jazzed up.
As you can see each row starts the count again Ignore the Personalization/Message line parts I can add these again later
I am in a mega rush so only whipped this up with one row of values (in A1 and B1)
I hope you can step through to understand it, wrap it in another loop to go through your 6000 rows, and change the msgbox to whatever output area you need... 6000 rows should be super quick:
Sub go()
Dim a() As String
Dim b() As String
Dim i As Long
Dim str As String
' split A1 and B1 based on their delimiter, into an array a() and b()
a() = Split(Range("A1").Value2, "x")
b() = Split(Range("B1").Value2, ",")
' quick check to make sure arrays are same size!
If UBound(a) <> UBound(b) Then Exit Sub
' this bit will need amended to fit your needs but I'm using & concatenate to just make a string with the outputs
For i = LBound(a) To UBound(b)
str = str & i + 1 & "-" & a(i) & "-" & b(i) & vbNewLine
Next i
' proof in the pudding
MsgBox str
End Sub
Sub test()
Dim rngDB As Range
Dim vR() As Variant
Dim i As Long
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp)) '<~~personaliation Max Char data range
ReDim vR(1 To rngDB.Count, 1 To 1)
For i = 1 To rngDB.Count
vR(i, 1) = textjoin(rngDB(i), rngDB(i, 2))
Next i
Range("c2").Resize(rngDB.Count) = vR '<~ result wil be recorded in Column C
End Sub
Function textjoin(rng1 As Range, rng2 As Range)
Dim vS1, vS2
Dim vR()
Dim i As Integer
vS1 = Split(rng1, "x")
vS2 = Split(rng2, ",")
ReDim vR(UBound(vS1))
For i = LBound(vS1) To UBound(vS1)
vR(i) = i + 1 & "-" & Trim(vS1(i)) & "-" & Trim(vS2(i))
Next i
textjoin = Join(vR, ",")
End Function
THANK YOU FOR ALL OF THE HELP
I went back to the drawing board having seen the above.
I learnt
That my original use of array formula and TEXTJOIN where over the top and hardly simplistic
That I can use VBA just like any other programming code :)
My Solution simplified from Dy.Lee
Function SPLITANDMERGE(arr1 As String, arr2 As String, Optional del1 As String = "x", Optional del2 As String = ",")
'Arr1 Split'
Dim aS1
'Arr2 Split'
Dim aS2
'Value Array'
Dim r()
'Value Count'
Dim v As Integer
'Split The Values'
aS1 = Split(arr1, del1)
aS2 = Split(arr2, del2)
'Count The Values'
ReDim r(UBound(aS1))
'For All The Values'
For v = LBound(aS1) To UBound(aS2)
'Create The String'
r(v) = "Personalisation_Line " & v + 1 & " - " & Trim(aS1(v)) & " Characters - [" & Trim(aS2(v)) & "]"
Next v
'Join & Return'
SPLITANDMERGE = Join(r, ", ")
End Function
I'm still working on it but I now get the following result.
Will Be Adding:
Value Count Comparison (If we have 4 and 5 Values return "-" to be picked up by conditional formatting)
Conditional plural values (If value 2 in the string is 0 then character instead of characters
If there are any pitfalls or errors anyone can see please do enlighten me. Im here to learn.
I am trying to separate multiple dates from one cell into multiple cells containing one date in a transposed area and then paste them back over the original area as separate entries.
An example cell might have dates stored like 10/1110/1110/13 or 10/310/310/410/5.
The second scenario is what is causing the error as there is no leading zero for single digit days like 10/3, for example.
Ideally, the code would separate the dates into separate cells like: 10/11,10/11,10/13 and 10/3,10/4,10/5. When single digits days are present ,however, it comes out completely jumbled up and inaccurate.
Admittedly, I had help from another coworker with this code who is on vacation currently, which is why I am having such trouble understanding this. Is there something I could change to account for single digit days or should I approach this process differently?
Thanks!
'separate column J by "/" and store in transpose area
dim h as variant
dim i as variant
dim j as variant
dim counter as variant
dim stringcheck as variant
dim strInput as variant
dim strCurrent as variant
strInput = Cells(j, 10)
h = 0
For counter = 1 To Len(strInput) - 2
stringcheck = InStr(strInput, "/")
Debug.Print j & stringcheck
If stringcheck <> 0 Then
If Mid(strInput, counter, 1) = "/" Then
Cells(17, i + h) = strCurrent & Mid(strInput, counter, 3)
counter = counter + 2
h = h + 1
strCurrent = vbNullString
Else
Cells(17, i + h) = Cells(j, 10)
strCurrent = strCurrent & Mid(strInput, counter, 1)
End If
'else just paste the value
Else
Cells(17, i) = strInput
End If
Next counter
If all of the months within one cell's mashed up dates can be reasonably assumed to be the same then that could be used as a delimiter to split the mash-up and reassemble it.
Function splitMashUp(str As String, _
Optional splitchr As String = "/", _
Optional delim As String = ", ")
Dim i As Long, tmp As Variant
tmp = Split(str, Left(str, InStr(1, str, splitchr)))
For i = LBound(tmp) + 1 To UBound(tmp)
tmp(i) = Left(str, InStr(1, str, splitchr)) & tmp(i)
Next i
splitMashUp = Mid(Join(tmp, delim), Len(delim) + 1)
End Function
My spreadsheet has a column with value like this string:
some text (text1) some test (text2) (text1)
How do I get all values between parentheses? The result I am looking for is:
text1, text2
Even if text1, text2... testn is present in the cell multiple times, I need it in the result only once.
I found a function GetParen here: Get the value between the brackets
It is helpful, but it gives the fist available value in the parentheses and ignores the rest.
It seems unwieldy to have one User Defined Function for individual entries and another for a collective result of all entries.
Paste the following into a standard module code sheet.
Function getBracketedText(str As String, _
Optional pos As Integer = 0, _
Optional delim As String = ", ", _
Optional dupes As Boolean = False)
Dim tmp As String, txt As String, a As Long, b As Long, p As Long, arr() As Variant
tmp = str
ReDim arr(1 To 1)
For b = 1 To (Len(tmp) - Len(Replace(tmp, Chr(40), vbNullString)))
p = InStr(p + 1, tmp, Chr(40))
txt = Trim(Mid(tmp, p + 1, InStr(p + 1, tmp, Chr(41)) - (p + 1)))
If UBound(Filter(arr, txt, True)) < 0 Or dupes Then '<~~ check for duplicates within the array
a = a + 1
ReDim Preserve arr(1 To a)
arr(UBound(arr)) = txt
End If
Next b
If CBool(pos) Then
getBracketedText = arr(pos)
Else
getBracketedText = Join(arr, delim)
End If
End Function
Use like any other native worksheet function. There are optional parameters to retrieve an individual element or a collection as well as changing the default <comma><space> delimiter.
This code works for me:
Sub takingTheText()
Dim iniP 'first parenthesis
Dim endP 'last parentehis
Dim myText 'the text
Dim txtLen
Dim i
Dim tmp
Dim j
myText = Range("A1").Value
txtLen = Len(myText)
j = 0
Do 'Loop in the text
i = i + 1 'a counter
iniP = InStr(1, myText, "(", 1) 'found the first occurence of the (
endP = InStr(1, myText, ")", 1) 'same as above
tmp = tmp & Right(Left(myText, i), 1) 'take the text garbage text
If i = iniP Then 'here comes the work
j = j + 1 'here take the cell index
myText = Replace(myText, tmp, "") 'remove the garbage text in front the first (
tmp = Left(myText, endP - iniP - 1) 'reuse the var to store the usefull text
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp 'store in the cell B1
'If you want to stored in separated cells use the below code
'Cells(j, 2).Value = tmp
myText = Replace(myText, tmp & ")", "", 1, 1) ' remove the garbage text from the main text
tmp = Empty 'empty the var
i = 0 'reset the main counter
End If
Loop While endP <> 0
End Sub
Result:
Please check and tellme if is ok.
Edit#1
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp this code store the text in separated lines inside the same cell, may be you want to use spaces between the resulting text because of chr(10) (also you can use chr(13)), then you can use Cells(1, 2).Value = Cells(1, 2).Value & " " & tmp, or use any other character instead the string inside the & symbols