PDA

View Full Version : VBA to Concatenate Multi-Value Cells



lneidorf
05-26-2015, 10:31 AM
Hi there.

I have a novel issue and haven't found any threads that touch on it.

I'd like to concatenate the corresponding contents of multivalue cells across four columns. A simple illustration of my data will be helpful:


Cell A2
Boston; New York

Cell B2
Pizza Regina; White Castle

Cell C2
Sales; Marketing

Cell D2
Cash Flow Report.xls; Marketing Memo.doc


I'm looking to use a VBA loop to generate this result:

RESULT, in Cell E2
Boston\Pizza Regina\Sales\Cash Flow Report.xls; New York\White Castle\Marketing\Marketing Memo.doc


I've got thousands of rows in a spreadsheet and am trying to construct a VBA loop to automate this throughout all rows. I should also point out that some of my cells contain as many as 11 strings separated by semi-colons. Every row in my data is different.

Any assistance would be extremely appreciated!

Thanks!

Kenneth Hobs
05-26-2015, 12:53 PM
Would all 4 cells contain the same number of semicolons? If not, the logic of how to handle that case would be needed.

lneidorf
05-26-2015, 01:31 PM
Hi Kenneth.

Thanks for your response.

The assumption is that all four cells would indeed contain the same number of strings / semicolons.

Thanks!

snb
05-27-2015, 12:11 AM
Sub M_snb()
sn = Cells(1).CurrentRegion

For j = 1 To UBound(sn)
sp = Split(Join(Application.Index(sn, j), ";"), ";")
ReDim st(UBound(sp) \ 4)

For jj = 0 To UBound(sp)
st(jj Mod (UBound(st) + 1)) = st(jj Mod (UBound(st) + 1)) & "\" & sp(jj)
Next

MsgBox Join(st, "|")
Next
End Sub

Kenneth Hobs
05-27-2015, 06:50 AM
Can you show me how this short two cell example would work for 3 elements? Once I understand the logic, it can be coded properly.

1; 2; 3 and a; b; c
= 1\a\2\b\3\c
or
= 1\a\2\3\b\c

lneidorf
05-27-2015, 07:21 AM
Kenneth,

The output, in a single cell, should look like this:
= 1\a; 2\b; 3\c

In reality, the individual columns (A - D) contain component parts of filepaths / filenames. I'm trying to piece them together to provide complete filepaths\filenames. The complication is that these cells are multavalue, each containing component parts of multiple filepaths / filenames. Unfortunately, the software I work with exports data in this fashion and cannot be altered.

Thanks for your help!

lneidorf
05-27-2015, 07:31 AM
snb,

Thanks for that.

A few questions:
1. Why does the code generate a message box with four \ characters? I'm trying to understand what in your code spawns that message box.
2. The result in the second message box is perfect! How can I get that output into a cell to the right of my source cells instead of a message box?
3. Will this routine loop through all populated rows in my sheet?

Thanks!

Kenneth Hobs
05-27-2015, 07:53 AM
Note that in my function, you need to set the reference by clicking Tools menu, References, and add that one.


Sub semicolonTobackslash()
Dim r As Range
Dim s() As String, ss() As String, str As String
Dim i As Integer, j As Integer, k As Integer

Set r = Range("A2").Resize(1, 4)
On Error Resume Next

Do Until r(1, 1).Value = ""
r.Copy
s() = Split(getClipboard, vbTab)

j = UBound(Split(s(0), ";"))
str = ""

For k = 0 To j
For i = 0 To UBound(s)
ss() = Split(s(i), ";")
If Left(str, 1) <> "" Then
str = str & "\" & Trim(ss(k))
Else
str = ss(k)
End If
Next i
str = str & "; "
Next k

str = Replace(Replace(str, vbCrLf, ""), "; \", "; ")
str = Left(str, Len(str) - 2)
Range("E" & r.Row).Value = str

Set r = r.Offset(1)
Loop

Application.CutCopyMode = False
End Sub


Function getClipboard()
'Add Reference: 'Reference: Microsoft Forms 2.0 Object
Dim MyData As DataObject

On Error Resume Next
Set MyData = New DataObject
MyData.GetFromClipboard
getClipboard = MyData.GetText
End Function

lneidorf
05-27-2015, 08:36 AM
Kenneth,

That's terrific. One thing missing: how can I get a space+semicolon to appear between the individual entries in the result?

In other words, where the source data looks like this:
1234 abcd

I'd like the result to look like this:
1\a; 2\b; 3\c; 4\d

Presently, the output of this code looks like:
1\a2\b3\c4\d

Thanks!

snb
05-27-2015, 08:58 AM
You might have made that slight amendment yourself.


Sub M_snb()
sn = Cells(1).CurrentRegion.Resize(, 5)

For j = 2 To UBound(sn)
sp = Split(Join(Application.Index(sn, j), ";"), ";")
ReDim st((UBound(sp) - 1) \ 4)

For jj = 0 To UBound(sp) - 1
st(jj Mod (UBound(st) + 1)) = st(jj Mod (UBound(st) + 1)) & "\" & sp(jj)
Next
sn(j, 5) = Join(st)
Next

Cells(1).CurrentRegion.Resize(, 5) = sn
End Sub

Kenneth Hobs
05-27-2015, 09:04 AM
Yes, I noticed that after I posted my code and read your post #6 and reread #1. I edited my post #8 code.

apo
05-27-2015, 09:25 AM
Here's my stab at it..



Private Sub CommandButton1_Click()
Dim x, zz, i As Long, ii As Long, iii As Long
x = Application.Transpose([A2].CurrentRegion)
ReDim zz(1 To UBound(x, 2))
For i = LBound(x, 2) To UBound(x, 2)
Z = Replace(Join(Application.Transpose(Application.Index(x, 0, 1)), vbLf), vbLf, ";")
For ii = 0 To 1
For iii = ii To 7 Step 2
If zz(i) = "" Then
zz(i) = zz(i) & Split(Z, ";")(iii)
Else: zz(i) = zz(i) & "\" & Split(Z, ";")(iii)
End If
Next iii
If iii > 7 And ii = 0 Then zz(i) = zz(i) & ";"
Next ii
zz(i) = Replace(zz(i), ";\", ";")
Next i
[E2].Resize(UBound(zz), 1).Value = zz
End Sub

lneidorf
05-27-2015, 11:02 AM
Thank you Kenneth, SNB, and APO. These are great. I'm a relative novice with VBA, so I will study these approaches and see what I can pick up from them.

Thanks so much for taking the time.