VBA Comma Separated Look-Up - excel

I'm looking to either use a formula or VBA to lookup values in column J associated with the same ID number and put them into any starting with "Master" in Column A separated by commas.
In the example below, I would like cell J2 to return
"D, G, R, N" and if there ere any duplicates to only have them listed once. The values in column J are currently looking up values from another list using the formula :
=IFERROR(IF(ISNUMBER(MATCH(M2,Sheet1!$J:$J,0)),"N",
IF(ISNUMBER(MATCH(M2,Sheet1!$K:$K,0)),"D",
IF(ISNUMBER(MATCH(M2,Sheet1!$L:$L,0)),"R",
IF(ISNUMBER(MATCH(M2,Sheet1!$M:$M,0)),"G",
IF(ISNUMBER(MATCH(M2,Sheet1!$N:$N,0)),"F",""))))), "")

You can use this UDF. Since you're looking for a formula, put this in the blank cells in Column J.
=get_areas(C2)
Then add this in to a Workbook Module:
Function get_areas(ID As String) As String
Dim rng As Range, cel As Range
Set rng = Range("A2:A" & Cells(rows.count,1).End(xlUp).Row)
Dim areas As String
For Each cel In rng
If IsNumeric(Left(cel, 1)) And cel.Offset(0, 2) = ID Then
If InStr(1, areas, cel.Offset(0, 9)) = 0 Then
areas = cel.Offset(0, 9) & ", " & areas
End If
End If
Next cel
areas = Trim(Left(areas, Len(areas) - 2))
get_areas = areas
End Function

Related

How to use activecell row and column in VBA function with filldown?

I wrote a function which will concatenate all the cells to the left of the cell the function is in, using a delimiter. My code is:
Public Function Concat_To_Left(delim As String)
Dim C, R As Long
Dim S As String
Dim Cell As Range
Set Cell = ActiveCell
C = Cell.Column
R = Cell.Row
S = Cells(R, 1).Value
For i = 2 To (C - 1)
S = S & delim & Cells(R, i).Value
Next i
Concat_To_Left = S
End Function
This code works if calculating a single row. The problem I'm running into is that the cell.row and cell.column seem to be saved from the first cell when I fill the function to the bottom of a column (by double clicking the bottom right of the cell in the excel sheet). This results in all cells with this function having the same value as the cell being filled down from.
Screen-Updating, Events, and Alerts are all on/true. Application.Calculation is set to xlCalculationAutomatic
Can anyone tell me how to make this function work on each cell the formula is filled down into, using the proper row and column for each cell (not that column matters when filling down)?
Scott's comment about using TEXT join worked as a workaround to what I was trying to accomplish.
=TEXTJOIN(", ",TRUE,B2:INDEX(2:2,COLUMN()-1))
The link he provided to the custom code for TEXTJOIN was very nice as well:
MS Excel - Concat with a delimiter
Adding Application.Volatile did not make my function work. I did not find a way to get my function working with fill down without needing a range parameter, so TEXTJOIN is the next best option and answers my question for now.
EDIT:
I wrote this macro to work instead of a function:
Private Sub Concat_To_Left()
Dim C, R, LR As Long
Dim Cell As Range
LR = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
C = ActiveCell.Column
R = ActiveCell.Row
For Each Cell In ActiveWorkbook.ActiveSheet.Range(Cells(R, C), Cells(LR, C))
Cell.Value = Cells(Cell.Row, 1).Value
For i = 2 To (C - 1)
Cell.Value = Cell.Value & "|" & Cells(Cell.Row, i).Value
Next i
Next Cell
End Sub
This one uses "|" as a delimiter, fills down from the active cell to lastrow concatenating every cell to the left, including blanks.

Excel vba select non blank cells in column A and create array offset from B

I have a list of values in column A2:A10 some are empty
What I would like to do is create a comma separated array of the adjacent values in column B.
Therefore if A3 = X and A6 = X and A9 = X
The result should be what is in Column B i.e. B3 = Y and B6 = Y and B9 = Y
These need to be presented in a comma separated array i.e. y,y,y
Note: the x and y values are different numbers, not actual X or Y
I can create the array offset, using the following but it selects all the values in column B, whereas I only want the adjacent ones from column A
Dim arr
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next 'if only 1 row
arr = Join(Application.Transpose(ThisWorkbook.Sheets("ID").Range("A2:A" & LR).Offset(0, 1).Value), ",")
MsgBox arr
There is no (probably) a simple method to create an array from discontinuous data range
Solutions can be many. Here's the next one.
Sub Makro1()
Dim rngScope As Range
Dim varArr As Variant
With Range("A1")
.Value = "X"
.CurrentRegion.AutoFilter Field:=1, Criteria1:="<>"
Set rngScope = .CurrentRegion.Columns(2)
End With
With rngScope
Set rngScope = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
End With
rngScope.Copy Range("E1")
With Range("E1").CurrentRegion
varArr = .Value
ActiveSheet.ShowAllData
.Clear
End With
With Range("A1")
.ClearContents
.AutoFilter
End With
varArr = Join(Application.Transpose(varArr), ",")
MsgBox varArr
End Sub
Artik
So you don't need to use an Application function for this function. You just need to build up the list of values, based on the state of the cell beside it. Here is some example code you can use:
Option Explicit
Sub test()
Debug.Print SelectedList(ThisWorkbook.Sheets("ID").Range("A1:B10"))
End Sub
Public Function SelectedList(ByRef inputArea As Range) As String
'--- the inputArea is a two-column range in which the left-hand column
' "selects" the value in the right-hand column by being non-blank
' the function returns a comma-separated string of values
Dim listResult As String
Dim dataPair As Range
For Each dataPair In inputArea.Rows
If Not IsEmpty(dataPair.Cells(, 1)) Then
listResult = listResult & dataPair.Cells(, 2).Value & ","
End If
Next dataPair
'--- return the list (and strip off the trailing comma)
SelectedList = Left$(listResult, Len(listResult) - 1)
End Function
And, as an added bonus, you can "call" this function directly from your worksheet. Just put this formula into a cell =SelectedList(A1:B10) and the resulting list will appear in the cell.

Enter User Defined Function into Column Using VBA

I currently am using a formula in Column J of Sheet 2 of my workbook that will look up values from 5 columns on Sheet 1 and return the corresponding text. For example if the value from column M on Sheet 2 matches any of the values from column J on Sheet 1 it would return "N", if not it would look in column K and if matched anything there it would return D, and so on. I am doing this in VBA so the formula used is
ActiveSheet.Range("J2:J" & intLastRow).FormulaR1C1 = _
"=IFERROR(IF(ISNUMBER(MATCH(RC[3],Sheet1!C10,0)),""N"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C11,0)),""D"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C12,0)),""R"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C13,0)),""G"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C14,0)),""F"",""""))))), """")"
This formula works well and fills in the corresponding values. I then created a user defined function that will look up all of the values in column J that are associated with an ID number found in column C and separate them by commas. This function also works well when entered into a cell.
Function get_areas(ID As String) As String
Dim rng As Range, cel As Range
Set rng = Range("A2:A" & Cells(rows.count,1).End(xlUp).Row)
Dim areas As String
For Each cel In rng
If IsNumeric(Left(cel, 1)) And cel.Offset(0, 2) = ID Then
If InStr(1, areas, cel.Offset(0, 9)) = 0 Then
areas = cel.Offset(0, 9) & ", " & areas
End If
End If
Next cel
areas = Trim(Left(areas, Len(areas) - 2))
get_areas = areas
End Function
Ideally, what I would like to do is run the original formula in all cells in column J that DON'T start with Master in Column A and then run the get_areas($C2) function in all cells that DO start with master in Column A. If that is not feasible, then I would like to run the get_areas function in all cells that are blank (meaning they didn't return anything from the original formula, but still have the formula in them) in VBA. I have tried modifying the original formula to read
ActiveSheet.Range("J2:J" & intLastRow).FormulaR1C1 =
"=IFERROR(IF(LEFT(RC[-9],6)=""master"", get_areas(RC[-7]),
IF(ISNUMBER(MATCH(RC[3],Sheet1!C10,0)),""N"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C11,0)),""D"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C12,0)),""R"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C13,0)),""G"",
IF(ISNUMBER(MATCH(RC[3],Sheet1!C14,0)),""F"","""")))))), """")"
but received errors about the get_areas function.
WorksheetFunction.Trim
All of this might have nothing to do with your case but might be useful in some similar cases. It just keeps ringing in my head and you know how it is when you can't keep your mouth shut.
I would have written the function like this:
Function get_areas(ID As String) As String
Dim rng As Range
Dim i As Long
Dim areas As String
Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
With rng
For i = 1 To .Cells.Count
If IsNumeric(Left(.Cells(i, 1))) And .Cells(i, 1).Offset(0, 2) = ID Then
If InStr(1, areas, .Cells(i, 1).Offset(0, 9)) = 0 Then
If i > 1 Then
areas = areas & ", " & .Cells(i, 1).Offset(0, 9)
Else
areas = .Cells(i, 1).Offset(0, 9)
End If
End If
End If
Next
End With
get_areas = WorksheetFunction.Trim(areas)
End Function
which in all is not so important as the 'WorksheetFunction' part.
WorksheetFunction.Trim removes all spaces except single spaces between words, while VBA's Trim function only removes the left and right spaces.
The other most noticeable difference is the 'If i > 1' block.

How to select mutiple values from excel single cell

I have excel cell having multiple rows of data with image url.
Now I want to select all images having 1500 value. So basically I want to select row starting with http and ending 1500.jpg.
Please not that in my single cell values are also other than 1500.jpg.Sample data is given below
colorImages': { 'initial': [{"hiRes":"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UL1500_.jpg","variant":"MAIN","lowRes":null},{"hiRes":"https://images-na.ssl-images-amazon.com/images/I/716mECZ9JDL._UL1500_.jpg","thumb":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL._SR38,50_.jpg","large""thumb":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL._SR38,50_.jpg","large":"https://images-na.ssl-images-amazon.com/images/I/313QD20m4WL.jpg","main":{"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY445_.jpg":[445,117],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY500_.jpg":[500,132],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY550_.jpg":[550,145],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY606_.jpg":[606,160],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY679_.jpg":[679,179],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY741_.jpg":[741,195],"https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._UY879_.jpg":[879,231]},
Assuming data is in Column A starting from Cell A2 and all the URLs ending with 1500.jpg needs to be displayed in adjacent columns i.e. same row Column B, Column C, Column D,.... then following might help.
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long, colIndex As Long
Dim rng As Range, cel
Dim X As Long, DotCount As Long
Dim Pat As String, EndPat As String, Parts() As String
Set ws = ThisWorkbook.Worksheets("Sheet3") 'change Sheet3 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last row with data in Column A
For Each cel In .Range(.Cells(2, 1), .Cells(lastRow, 1)) 'loop through A2 to last cell with data in Column A
colIndex = 1
Pat = "*[!&-;?-[_a-z~=!" & Chr$(1) & "]."
EndPat = "[!&-;?-[_a-z~=!" & Chr$(1) & "]*"
Parts = Split(cel.Value, """") 'split cell value into an array
For X = 0 To UBound(Parts)
If Parts(X) Like "*?.?*" Then
DotCount = Len(Parts(X)) - Len(Replace(Parts(X), ".", ""))
If """" & Replace(Parts(X), "]", Chr$(1)) & """" Like Application.Rept(Pat, DotCount) & EndPat Then
Parts(X) = ""
ElseIf Right(Parts(X), 8) <> "1500.jpg" Then
Parts(X) = ""
Else
cel.Offset(0, colIndex) = Parts(X) 'display URL
colIndex = colIndex + 1
End If
Else
Parts(X) = ""
End If
Next X
Next cel
End With
End Sub
Derived this solution using Function URLs from here.
This is done easily via VBA, but am not expert in that. So I have done some thing for you,just follow the instruction , still it is apply to get only single search entry i.e. means in a cell its find only one 1500.jpg entry.
To get second entry in the same cell you need some effort via change or get substring from the G1 Cell string and repeat the step as explained again.
In A1 Cell, put 1500.jpg
In B1 Cell, put your actual string as you have above
In C1 cell, put formula "=SEARCH(A1,B1)", which find the search 1500 in string
In D1 cell, put formula "=MID(B1,1,C1)", which extract the substring
For E1 we need reverse the string via VBA code - Add Reversestr function (To add this function, see this link)
In F1 cell, put formula "=SEARCH(CHAR(34),E1)", which search " in above reverse string
In G1 cell, put formula "=MID(B1,C1-F1+1,C1)"
Finally you get the string in G1 Cell as "https://images-na.ssl-images-amazon.com/images/I/71GOT-L%2BOSL._1500.jpg"
For VBa formula, check this links
http://analystcave.com/excel-substring-vba-substring/

Macro to move number with dash to new cell

In Excel, I am trying to get a macro to move numbers with a "-".
I have a column E with a list of numbers
54525841-1
454152
1365466
1254566-1
1452577-1
I want a macro to move all the numbers that have a dash or hyphen at the end to column C.
So I would need E1 54525841-1 to be moved to C1.
You'll need to change "Sheet1" to the name of the sheet where your data is.
This looks through every cell (with data) in the E column and moves the value accross to the C column if it contains a dash.
Sub MoveDashes()
Dim Sheet As Worksheet
Dim Index As Long
Set Sheet = ThisWorkbook.Worksheets("Sheet1")
For Index = 1 To Sheet.Cells(Application.Rows.Count, "E").End(xlUp).Row
If InStr(1, Sheet.Cells(Index, "E"), "-") > 0 Then
Sheet.Cells(Index, "C") = Sheet.Cells(Index, "E").Value
Sheet.Cells(Index, "E").Value = ""
End If
Next
End Sub
Does it have to be a macro? How about Advanced Filter?
Your numbers are in column E. Let's assume they have a header.
E1: Number
E2: 54525841-1
E3: 454152
E4: 1365466
E5: 1254566-1
E6: 1452577-1
In a separate area of your worksheet (let's say column G) put the following criteria:
G1: Number
G2: *-*
Your advanced filter criteria would look like this:
Anything with a "-" in it will be copied to column C.
I got it to work by this:
Sub MoveDash()
x = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Range("E2:E" & x)
If InStr(Cell, "-") <> 0 Then
Cell.Offset(, 1) = Cell
Cell.ClearContents
End If
Next Cell
end sub
You can do this without VBA, but here is an efficient way to do it using the dictionary object.
Sub MoveNumbersWithDash()
Application.ScreenUpdating = False
Dim i As Long, lastRow As Long
Dim varray As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
lastRow = Range("E" & Rows.Count).End(xlUp).Row
varray = Range("E1:E" & lastRow).Value
For i = 1 To UBound(varray, 1)
If InStr(1, varray(i, 1), "-") <> 0 Then
dict.Add i, varray(i, 1)
End If
Next
Range("C1").Resize(dict.Count).Value = _
Application.WorksheetFunction.Transpose(dict.items)
Application.ScreenUpdating = True
End Sub
How it works:
The major theme here is avoiding calls to Excel (like a for each loop). This will make the function blazing fast (especially if you have tens and thousands of rows) and more efficient. First I locate the last cell used in E then dump the entire row into a variant array in one move. Then I loop through each element, checking if it contains a "-", if it does, I add it to a dictionary object. POINT: Add the entry as the ITEM, not KEY. This makes sure that we allow for duplicates. The variable I will be unique for each entry, so I use that as the key. Then I simple dump the entire array of cells with "-" into column C.
Why Dictionary?
The dictionary object is very fast and comes with 2 really great functions: .Keys and .Items. These will return an array of all the keys or items in the dictionary, which you can use the Transpose function on to dump an entire column of values into Excel in one step. Super efficient.

Resources