Related
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
I want to run a search over a range of cells and check if they contain a combination of specific numbers, even better if taken from the string contained in the cell within the same range. i.e: I want to check if cells B2:B16 contain both 1 and 2.
I then want to take the values from column A, in the rows which matched the search, and return them to a single cell in column C.
In the example shown n, cell C2 lists all the ID numbers from Column A from rows, which correspond to the cells in column B which contain a string with the number "1". (Bonus for the one who also adds an automation on extracting the number from each cell's string).
The job gets trickier when descending down the cells in column B, as the search has to find string with a combination of several numbers (AND rule).
The only way I managed to get the results in cell C2 is by using a very long combination of:IF(ISNUMBER(SEARCH, which is not practical, as I need to manually adjust it for each cell in Column C.
The formula is as follows:
=IF(ISNUMBER(SEARCH(D2,B3,14)),A3," ")&IF(ISNUMBER(SEARCH(D2,B4,14)),A4," ")&IF(ISNUMBER(SEARCH(D2,B5,14)),A5," ")&IF(ISNUMBER(SEARCH(D2,B6,14)),A6," ")&IF(ISNUMBER(SEARCH(D2,B7,14)),A7," ")&IF(ISNUMBER(SEARCH(D2,B8,14)),A8," ")&IF(ISNUMBER(SEARCH(D2,B9,14)),A9," ")&IF(ISNUMBER(SEARCH(D2,B10,14)),A10," ")&IF(ISNUMBER(SEARCH(D2,B11,14)),A11," ")&IF(ISNUMBER(SEARCH(D2,B12,14)),A12," ")&IF(ISNUMBER(SEARCH(D2,B13,14)),A13," ")&IF(ISNUMBER(SEARCH(D2,B14,14)),A14," ")&IF(ISNUMBER(SEARCH(D2,B15,14)),A15," ")&IF(ISNUMBER(SEARCH(D2,B16,14)),A16," ")
Any idea on how I can make this whole operation more efficient?
Try this function:
Function GetMatches(InputCell As Range, SearchRange As Range) As String
Dim MyArray() As Variant
Dim Res As String
Dim X As Long, Y As Long, Z As Long
Dim CL As Range
'Get numbers from target cell
Y = 0
For X = 1 To Len(InputCell.Value)
If Mid(InputCell.Value, X, 1) >= "0" And Mid(InputCell.Value, X, 1) <= "9" Then
Y = Y + 1
ReDim Preserve MyArray(Y)
MyArray(Y) = Mid(InputCell.Value, X, 1)
End If
Next X
'Loop through all cells in specified range
For Each CL In SearchRange
For Z = LBound(MyArray) To UBound(MyArray)
If InStr(1, CL.Value, MyArray(Z)) = 0 Then GoTo 1
Next Z
If CL.Row <> InputCell.Row Then Res = Res & CL.Offset(0,-1).value & " "
1: Next CL
GetMatches = Res
End Function
Call in your sheet by adding this formula in cell C2: =GetMatches(B2,$B$2:$B$16) and drag down.
For your second request you could do it like so:
Function GetMatches2(InputCell As Range, SearchRange As Range) As String
Dim MyArray() As String
Dim Res As String, Inp As String
Dim X As Long, Y As Long, Z As Long
Dim CL As Range
'Get codes from inputcell
MyArray = Split(Replace(Application.WorksheetFunction.Trim(Right(InputCell, Len(InputCell) - InStr(1, InputCell, "\"))), " and ", "\"), "\")
'Loop through all cells in specified range
For Each CL In SearchRange
For Z = LBound(MyArray) To UBound(MyArray)
Inp = "\" & Replace(Application.WorksheetFunction.Trim(Right(CL.Value, Len(CL.Value) - InStr(1, CL.Value, "\"))), " and ", "\")
If InStr(1, Inp, "\" & MyArray(Z)) = 0 Then GoTo 1
Next Z
If CL.Row <> InputCell.Row Then Res = Res & CL.Offset(0, -1).Value & " "
1: Next CL
GetMatches = Res
End Function
Call in your sheet by adding this formula in cell C2: =GetMatches2(B2,$B$2:$B$16) and drag down.
My sub compares two lists of strings and returns the closest matches. I've found that the sub gets tripped up over some common words such as "the" and "facility". I would like to write a function that would be supplied an array of words to exclude and check each string for these words and exclude them if found.
Here is a sample input:
|aNames | bNames | words to exclude
|thehillcrest |oceanview health| the
|oceanview, the|hillCrest | health
Intended Output:
|aResults |bResuts
|hillcrest |hillcrest
|oceanview |oceanview
So far I have:
Dim ub as Integer
Dim excludeWords() As String
'First grab the words to be excluded
If sheet.Cells(2, 7).Value <> "" Then
For y = 2 To sheet.Range("G:G").End(xlDown).Row
ub = UBound(excludeWords) + 1 'I'm getting a subscript out of range error here..?
ReDim Preserve excludeWords(0 To ub)
excludeWords(ub) = sheet.Cells(y, 7).Value
Next y
End If
Then my comparison function, using a double loop, will compare each string in column A with column B. Before the comparison, the value in column a and b will go through our function which will check for these words to exclude. It's possible that there will be no words to exclude, so the parameter should be optional:
Public Function normalizeString(s As String, ParamArray a() As Variant)
if a(0) then 'How can I check?
for i = 0 to UBound(a)
s = Replace(s, a(i))
next i
end if
normalizeString = Trim(LCase(s))
End Function
There's probably a few parts in this code that won't work. Might you be able to point me in the right direction?
Thank you!
To store the list in the array, you can do this
Sub Sample()
Dim excludeWords As Variant
Dim lRow As Long
With Sheet1 '<~~ Change this to the relevant sheet
'~~> Get last row in Col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
excludeWords = .Range("G2:G" & lRow).Value
'Debug.Print UBound(excludeWords)
'For i = LBound(excludeWords) To UBound(excludeWords)
'Debug.Print excludeWords(i, 1)
'Next i
End With
End Sub
And then pass the array to your function. The above array is a 2D array and hence needs to be handled accordingly (see commented section in the code above)
Also like I mentioned in the comments above
How does oceanview, the become Oceanview? You can replace the but that would give you oceanview, (notice the comma) and not Oceanview.
You may have to pass those special characters to Col G in the sheet or you can handle them in your function using a loop. For that you will have to use the ASCII characters. Please see this
Followup from comments
Here is something that I wrote quickly so it is not extensively tested. Is this what you are looking for?
Sub Sample()
Dim excludeWords As Variant
Dim lRow As Long
With Sheet1
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
excludeWords = .Range("G2:G" & lRow).Value
'~~> My column G has the word "habilitation" and "this"
Debug.Print normalizeString("This is rehabilitation", excludeWords)
'~~> Output is "is rehabilitation"
End With
End Sub
Public Function normalizeString(s As String, a As Variant) As String
Dim i As Long, j As Long
Dim tmpAr As Variant
If InStr(1, s, " ") Then
tmpAr = Split(s, " ")
For i = LBound(a) To UBound(a)
For j = LBound(tmpAr) To UBound(tmpAr)
If LCase(Trim(tmpAr(j))) = LCase(Trim(a(i, 1))) Then tmpAr(j) = ""
Next j
Next i
s = Join(tmpAr, " ")
Else
For i = LBound(a) To UBound(a)
If LCase(Trim(s)) = LCase(Trim(a(i, 1))) Then
s = ""
Exit For
End If
Next i
End If
normalizeString = Trim(LCase(s))
End Function
First of all, you cannot call UBound function for the Array that doesn't have a size yet:
Dim excludeWords() As String
ub = UBound(excludeWords) + 1 'there is no size yet
To remove some of the unwanted words use Replace function
String1 = Replace(String1, "the", "")
To do the comparison you described I would use Like function. Here is documentation.
http://msdn.microsoft.com/pl-pl/library/swf8kaxw.aspx
I have a set of descriptions that contain ID numbers arranged into a column. For example:
Column A
This is a description with the ID number in it ID12345.
This is a description ID66666 with the ID number in it.
This is ID99999 a description with the ID number in it.
The Id numbers are always in the format "IDXXXXX" I'd like to somehow trim away all the text in each of these cells and leave just that ID number.
My thoughts:
Can this be somehow done by finding a string like "ID?????" and setting that to a variable, then replacing the contents of the cell with that variable? Or by erasing all characters in a cell -except- for "ID?????"
Any help would be appreciated, thanks.
This code I wrote for you will iterate through all items in Column A. It will split all the words in each cell into an array. If the word is 7 or 8 characters long then it could potentially be an IDxxxxx. It will perform a few checks to see if it really matches an IDxxxxx syntax. In case it does it will replace the contents of the cell with just the ID dropping all the remaining text.
Sub ReplaceContentWithIDs()
Dim ws As Worksheet
Set ws = Sheets("Sheet1") ' or your sheet name
Dim rng As Range
Dim i&, lr&, j&
Dim arr
Dim str$
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' starting from 1 - if you have headers change to 2
For i = 1 To lr
Set rng = ws.Range("A" & i)
arr = Split(CStr(rng.Value), " ")
For j = LBound(arr) To UBound(arr)
str = arr(j)
If (Len(str) = 7) Or (Len(str) = 8) Then
If (StrComp(Left(str, 2), "ID", vbTextCompare) = 0) And _
IsNumeric(Right(Left(str, 7), 5)) Then
' found it
If Len(str) = 8 Then
rng.Value = Left(str, 7)
ElseIf Len(str) = 7 Then
rng.Value = str
End If
End If
End If
Next j
Set rng = Nothing
Next i
End Sub
I took this as a challenge to my intellect, and given that it is the end of the day, after seeing the formulas by Aladdin and pgc01 on Mr Excel forums I did a little work and came up with this CSE (Array formula):
=IF(ISNUMBER(LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1))),MID(A1,LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1)),7),"")
I also had some luck with this CSE Array formula:
=IF(ISNUMBER(SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1)),MID(A$1,SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1),7))
I have a number of ranges to concatenate independently and put the values of the concatenated ranges into different cells.
I want to:
concatenate values in Range A1:A10 and put the result in F1
then concatenate the Range B1:B10 and put the result in F2
then concatenate the Range C1:C10 and put the result in F3 etc.
The following macro concatenates range A1:A10 and then puts the results into F1 (which is what I want). However it also stores the information from the first concatenation into memory so that when it does the next concatenation, in cell F2 I get the concatenated results of F1 and F2 joined.
Sub concatenate()
Dim x As String
Dim Y As String
For m = 2 To 5
Y = Worksheets("Variables").Cells(m, 5).Value
'Above essentially has the range information e.g. a1:a10 in sheet variables
For Each Cell In Range("" & Y & "") 'i.e. range A1:A10
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'this provides the concatenated cell value
Next
Line1:
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next m
End Sub
Here is my ConcatenateRange. It allows you to add a seperator if you please. It is optimized to handle large ranges since it works by dumping the data in a variant array and working with it within VBA.
You would use it like this:
=ConcatenateRange(A1:A10)
The code:
Function ConcatenateRange(ByVal cell_range As range, _
Optional ByVal seperator As String) As String
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
... I would do this very differently... Why not create a function along the lines of:
Function ConcatMe(Rng As Range) As String
Dim cl As Range
ConcatMe = ""
For Each cl In Rng
ConcatMe = ConcatMe & cl.Text
Next cl
End Function
And then just, for example, set F1 = ConcatMe(A1:A10) or, then write code to assign the function to the cells you want...
Or, as #KazJaw mentioned in his comment, just set x="" before re-looping.
Hope this helps
it is similar to the idea posted here already. However, I use a for each loop instead of an array setup with nested for loops.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = "")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
This, I suppose would be faster than the array set up, as a new array is not created each time this function runs.
Right before Next m insert simple statement: x="" – KazimierzJawor Apr 8 '13 at 20:43
took me several minutes to notice this answer was under comments :p
Thanks for everything guys, for my purpose I have modified your suggestions and amended my code as it didn't quite fit into a neat function as I needed it to be more dynamic. See my code below. It does exactly what I need.
Sub concatenate()
Dim x As String
Dim Y As String
For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement
For T = 1 To 10 'This provides a rows reference to concatenate - Inner for statement
For Each Cell In Cells(T, Q) 'provides rows and column reference
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'This provides the concatenated cell value and comma separator
Next ' this loops the range
Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached
Line1:
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate
ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to
'give 2,3,4
ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2
x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range
Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again
Terminate: 'error handler
End Sub
#Issun's solution doesn't accept output from a worksheet array formula as the argument for the 'cell_range' parameter. But a slight modification to #Issun's code fixes this. I also added a check that ignores each cell whose value is FALSE.
Function ConcatenateRange( _
ByVal cellArray As Variant, _
Optional ByVal seperator As String _
) As String
Dim cell As Range
Dim newString As String
Dim i As Long, j As Long
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
If (cellArray(i, j) <> False) Then
newString = newString & (seperator & cellArray(i, j))
End If
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
For example:
A B (<COL vROW)
------ ------ -----------------
one 1 3
two 1 4
three 2 5
four 2 6
Enter into cell C1 the formula below and press CTRL+ENTER to store the formula as an array formula:
{=ConcatenateRange(IF(B3:B6=1,A3:A6),CHAR(10))}
I was looking further to see if there is a better way of writing concatenate function and found this. It seems that we all have the same working principle for the function. So its ok.
But my function is different that it can take multiple parameters, in combination of ranges, texts and numbers.
I assume that a delimiter is mandatory, so if i don't need it i just put "" as the last parameter).
I also assume that blank cells are not to be skipped. That's the reason why i want the function to take multiple parameters, so i can easily omit those that that i don't want in the concatenation.
Example of use:
=JoinText(A1:D2,F1:I2,K1:L1,";")
You can also use together text and number among the parameters:
=JoinText(A1:D2,123,F1:I2,K1:L1,"PQR",";")
I'd love to hear any comments or suggestions where it can be improved.
Here is the code.
Public Function JoinText(ParamArray Parameters() As Variant) As String
Dim p As Integer, c As Integer, Delim As String
Delim = Parameters(UBound(Parameters))
For p = 0 To UBound(Parameters) - 1
If TypeName(Parameters(p)) = "Range" Then
For c = 1 To Parameters(p).Count
JoinText = JoinText & Delim & Parameters(p)(c)
Next c
Else
JoinText = JoinText & Delim & Parameters(p)
End If
Next p
JoinText = Replace(JoinText, Delim, "", , 1, vbBinaryCompare)
End Function
Function ConcatenateRange to concatenate all cells in range if they are not empty and empty "" string.
Function ConcatenateRange(cellRange As Range, Optional Delimiter As String) As String
Dim cel As Range, conStr As String
conStr = ""
If Delimiter <> "" Then
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel & Delimiter
Next
ConcatenateRange = Left(conStr, Len(conStr) - Len(Delimiter))
Else
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel
Next
ConcatenateRange = conStr
End If
End Function
Its very simple brother, Look out of the Excel. No need for all cumbersome formula or VBA.
Just copy all the cells that you need to concatenate and paste it in the notepad. Now just select the space between the lines/columns (it's a TAB space actually) and find and replace it.. Done.. All cells are concatenated. Now just copy and paste it in the column and just verify.. Thats it :) Enjoy.
I suggest you to use Notepad++ for this :) Koodos
Vimarsh
Ph. D. Plant Biotech.
/