concentrate muli cells

  • Thread starter Thread starter Dylan @ UAFC
  • Start date Start date
D

Dylan @ UAFC

I need to concetrate 1000 cells
into one single cell seperated by , and space
please advise
 
You would need to add a new function to do this. Are you ok with using the
VBEditor?

Press Alt-F11
Click Insert > Module
Paste in this code (sorry, it's a little long, be sure you get it all):

===========
Function StringConcat(Sep As String, ParamArray Args()) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' StringConcat
' This function concatenates all the elements in the Args array,
' delimited by the Sep character, into a single string. This function
' can be used in an array formula.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim S As String
Dim N As Long
Dim M As Long
Dim R As Range
Dim NumDims As Long
Dim LB As Long
Dim IsArrayAlloc As Boolean

'''''''''''''''''''''''''''''''''''''''''''
' If no parameters were passed in, return
' vbNullString.
'''''''''''''''''''''''''''''''''''''''''''
If UBound(Args) - LBound(Args) + 1 = 0 Then
StringConcat = vbNullString
Exit Function
End If


For N = LBound(Args) To UBound(Args)
''''''''''''''''''''''''''''''''''''''''''''''''
' Loop through the Args
''''''''''''''''''''''''''''''''''''''''''''''''
If IsObject(Args(N)) = True Then
'''''''''''''''''''''''''''''''''''''
' OBJECT
' If we have an object, ensure it
' it a Range. The Range object
' is the only type of object we'll
' work with. Anything else causes
' a #VALUE error.
''''''''''''''''''''''''''''''''''''
If TypeOf Args(N) Is Excel.Range Then
'''''''''''''''''''''''''''''''''''''''''
' If it is a Range, loop through the
' cells and create append the elements
' to the string S.
'''''''''''''''''''''''''''''''''''''''''
For Each R In Args(N).Cells
S = S & R.Text & Sep
Next R
Else
'''''''''''''''''''''''''''''''''
' Unsupported object type. Return
' a #VALUE error.
'''''''''''''''''''''''''''''''''
StringConcat = CVErr(xlErrValue)
Exit Function
End If

ElseIf IsArray(Args(N)) = True Then

On Error Resume Next
'''''''''''''''''''''''''''''''''''''
' ARRAY
' If Args(N) is an array, ensure it
' is an allocated array.
'''''''''''''''''''''''''''''''''''''
IsArrayAlloc = (Not IsError(LBound(Args(N))) And _
(LBound(Args(N)) <= UBound(Args(N))))
On Error GoTo 0
If IsArrayAlloc = True Then
''''''''''''''''''''''''''''''''''''
' The array is allocated. Determine
' the number of dimensions of the
' array.
'''''''''''''''''''''''''''''''''''''
NumDims = 1
On Error Resume Next
Err.Clear
NumDims = 1
Do Until Err.Number <> 0
LB = LBound(Args(N), NumDims)
If Err.Number = 0 Then
NumDims = NumDims + 1
Else
NumDims = NumDims - 1
End If
Loop
''''''''''''''''''''''''''''''''''
' The array must have either
' one or two dimensions. Greater
' that two caues a #VALUE error.
''''''''''''''''''''''''''''''''''
If NumDims > 2 Then
StringConcat = CVErr(xlErrValue)
Exit Function
End If
If NumDims = 1 Then
For M = LBound(Args(N)) To UBound(Args(N))
If Args(N)(M) <> vbNullString Then
S = S & Args(N)(M) & Sep
End If
Next M

Else
For M = LBound(Args(N), 1) To UBound(Args(N), 1)
If Args(N)(M, 1) <> vbNullString Then
S = S & Args(N)(M, 1) & Sep
End If
Next M
For M = LBound(Args(N), 2) To UBound(Args(N), 2)
If Args(N)(M, 2) <> vbNullString Then
S = S & Args(N)(M, 2) & Sep
End If
Next M

End If
Else
S = S & Args(N) & Sep
End If
Else
S = S & Args(N) & Sep
End If
Next N

'''''''''''''''''''''''''''''''''''
' Remove the trailing Sep character
'''''''''''''''''''''''''''''''''''
If Len(Sep) > 0 Then
S = Left(S, Len(S) - Len(Sep))
End If

StringConcat = S

End Function
===========

The code is also available here:
http://www.cpearson.com/excel/stringconcatenation.aspx

Press Alt-Q to close the editor and save your sheet. You've just added a
function called StringConcat() to your sheet and it works very simply.

If your 1000 cells are range A1:A1000, use this formula in another cell:

=StringConcat(", ",A1:A1000)

Voila! Works like a charm. Will that work for you?
 
Add this UDF to a general module.

Function ConCatRange(CellBlock As Range) As String
Dim Cell As Range
Dim sbuf As String
For Each Cell In CellBlock
If Len(Cell.text) > 0 Then sbuf = sbuf & Cell.text & ", "
Next
ConCatRange = Left(sbuf, Len(sbuf) - 1)
End Function

=concatrange(A1:A1000)


Gord Dibben MS Excel MVP
 
That is wonderfully concise. Is there any way to add an argument so the
delimiters (if any) are added in the user function?

=ConcatRange(", ",A1:A1000)

I would love to use the briefer version, but I need to retain the ability to
define the delimiter or use no delimiter at all.

Thanks.
 
If Gord will excuse me playing with his code then you do it like this.
Delimeter is optional. you enter your own or if you leave it the default
comma is used

=concatrange(A1:A100,"-")

or

=concatrange(A1:A100)



Function ConCatRange(CellBlock As Range, _
Optional delimeter As String) As String
If delimeter = "" Then delimeter = ","
Dim Cell As Range
Dim sbuf As String
For Each Cell In CellBlock
If Len(Cell.Text) > 0 Then sbuf = sbuf & Cell.Text & delimeter
Next
ConCatRange = Left(sbuf, Len(sbuf) - 1)
End Function

Mike
 
Option Explicit
Function ConCatRange(CellBlock As Range, Optional Delim As String = "") _
As String

Dim Cell As Range
Dim sbuf As String

For Each Cell In CellBlock.Cells
If Cell.Text <> "" Then
sbuf = sbuf & Cell.Text & Delim
End If
Next Cell

ConCatRange = Left(sbuf, Len(sbuf) - Len(Delim))

End Function

(With minor variations to Gord's code--just to be different!)

=ConcatRange(A1:A1000, ", ")
or
=ConcatRange(A1:A1000, "")
or even
=ConcatRange(A1:A1000)
 
looked scary, but worked like a charm

Gord Dibben said:
Add this UDF to a general module.

Function ConCatRange(CellBlock As Range) As String
Dim Cell As Range
Dim sbuf As String
For Each Cell In CellBlock
If Len(Cell.text) > 0 Then sbuf = sbuf & Cell.text & ", "
Next
ConCatRange = Left(sbuf, Len(sbuf) - 1)
End Function

=concatrange(A1:A1000)


Gord Dibben MS Excel MVP
Click to expand...
 
I like the improvement Dave.

Gord

Option Explicit
Function ConCatRange(CellBlock As Range, Optional Delim As String = "") _
As String

Dim Cell As Range
Dim sbuf As String

For Each Cell In CellBlock.Cells
If Cell.Text <> "" Then
sbuf = sbuf & Cell.Text & Delim
End If
Next Cell

ConCatRange = Left(sbuf, Len(sbuf) - Len(Delim))

End Function

(With minor variations to Gord's code--just to be different!)

=ConcatRange(A1:A1000, ", ")
or
=ConcatRange(A1:A1000, "")
or even
=ConcatRange(A1:A1000)
Click to expand...
 
See Dave's improved version of the UDF

Note the UDF will not accept non-contiguous ranges.

For non-contiguous cells or ranges you can use this macro.

Sub ConCat_Cells()
Dim X As Range
Dim y As Range
Dim Z As Range
Dim w As String
Dim sbuf As String
On Error GoTo endit
w = InputBox("Enter the Type of De-limiter(s) Desired")
Set Z = Application.InputBox("Select Destination Cell", _
"Destination Cell", , , , , , 8)
Application.SendKeys "+{F8}"
Set X = Application.InputBox("Select Cells, Contiguous or _
Non-Contiguous", _
"Cells Selection", , , , , , 8)
For Each y In X
If Len(y.text) > 0 Then sbuf = sbuf & y.text & w
Next
Z = Left(sbuf, Len(sbuf) - Len(w))
Exit Sub
endit:
MsgBox "Nothing Selected. Please try again."
End Sub


Gord
 
But by changing it to a subroutine from a function, the ability to use it in a
formula in a worksheet cell is lost.

But you could pass the range (in a infrequently used) syntax:

=ConCatRange((A1:A10,B3:B5),", ")

Those inside ()'s and comma are necessary.
 
is there a charcter max in this formula

JBeaucaire said:
You would need to add a new function to do this. Are you ok with using the
VBEditor?

Press Alt-F11
Click Insert > Module
Paste in this code (sorry, it's a little long, be sure you get it all):

===========
Function StringConcat(Sep As String, ParamArray Args()) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' StringConcat
' This function concatenates all the elements in the Args array,
' delimited by the Sep character, into a single string. This function
' can be used in an array formula.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim S As String
Dim N As Long
Dim M As Long
Dim R As Range
Dim NumDims As Long
Dim LB As Long
Dim IsArrayAlloc As Boolean

'''''''''''''''''''''''''''''''''''''''''''
' If no parameters were passed in, return
' vbNullString.
'''''''''''''''''''''''''''''''''''''''''''
If UBound(Args) - LBound(Args) + 1 = 0 Then
StringConcat = vbNullString
Exit Function
End If


For N = LBound(Args) To UBound(Args)
''''''''''''''''''''''''''''''''''''''''''''''''
' Loop through the Args
''''''''''''''''''''''''''''''''''''''''''''''''
If IsObject(Args(N)) = True Then
'''''''''''''''''''''''''''''''''''''
' OBJECT
' If we have an object, ensure it
' it a Range. The Range object
' is the only type of object we'll
' work with. Anything else causes
' a #VALUE error.
''''''''''''''''''''''''''''''''''''
If TypeOf Args(N) Is Excel.Range Then
'''''''''''''''''''''''''''''''''''''''''
' If it is a Range, loop through the
' cells and create append the elements
' to the string S.
'''''''''''''''''''''''''''''''''''''''''
For Each R In Args(N).Cells
S = S & R.Text & Sep
Next R
Else
'''''''''''''''''''''''''''''''''
' Unsupported object type. Return
' a #VALUE error.
'''''''''''''''''''''''''''''''''
StringConcat = CVErr(xlErrValue)
Exit Function
End If

ElseIf IsArray(Args(N)) = True Then

On Error Resume Next
'''''''''''''''''''''''''''''''''''''
' ARRAY
' If Args(N) is an array, ensure it
' is an allocated array.
'''''''''''''''''''''''''''''''''''''
IsArrayAlloc = (Not IsError(LBound(Args(N))) And _
(LBound(Args(N)) <= UBound(Args(N))))
On Error GoTo 0
If IsArrayAlloc = True Then
''''''''''''''''''''''''''''''''''''
' The array is allocated. Determine
' the number of dimensions of the
' array.
'''''''''''''''''''''''''''''''''''''
NumDims = 1
On Error Resume Next
Err.Clear
NumDims = 1
Do Until Err.Number <> 0
LB = LBound(Args(N), NumDims)
If Err.Number = 0 Then
NumDims = NumDims + 1
Else
NumDims = NumDims - 1
End If
Loop
''''''''''''''''''''''''''''''''''
' The array must have either
' one or two dimensions. Greater
' that two caues a #VALUE error.
''''''''''''''''''''''''''''''''''
If NumDims > 2 Then
StringConcat = CVErr(xlErrValue)
Exit Function
End If
If NumDims = 1 Then
For M = LBound(Args(N)) To UBound(Args(N))
If Args(N)(M) <> vbNullString Then
S = S & Args(N)(M) & Sep
End If
Next M

Else
For M = LBound(Args(N), 1) To UBound(Args(N), 1)
If Args(N)(M, 1) <> vbNullString Then
S = S & Args(N)(M, 1) & Sep
End If
Next M
For M = LBound(Args(N), 2) To UBound(Args(N), 2)
If Args(N)(M, 2) <> vbNullString Then
S = S & Args(N)(M, 2) & Sep
End If
Next M

End If
Else
S = S & Args(N) & Sep
End If
Else
S = S & Args(N) & Sep
End If
Next N

'''''''''''''''''''''''''''''''''''
' Remove the trailing Sep character
'''''''''''''''''''''''''''''''''''
If Len(Sep) > 0 Then
S = Left(S, Len(S) - Len(Sep))
End If

StringConcat = S

End Function
===========

The code is also available here:
http://www.cpearson.com/excel/stringconcatenation.aspx

Press Alt-Q to close the editor and save your sheet. You've just added a
function called StringConcat() to your sheet and it works very simply.

If your 1000 cells are range A1:A1000, use this formula in another cell:

=StringConcat(", ",A1:A1000)

Voila! Works like a charm. Will that work for you?
Click to expand...
 
I never knew that<g>

The extra parens are what makes it work.

Just keep on learnin'


Gord
 
What if I wanted to use this in an if formual
tbl array or range would have an office name in col C, email address in Col
F
Say Dallas, Austin and Seatlle
The email address that need to consolidated are in col f
I would like to set up were
if(-- the range col c -- $c$1:$c$500="office name" -- considate all the
email
address in col F associated with that office name, delimiter "; ")

Please advise
 
Back
Top