VBA to Concatenate Multi-Value Cells

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!

Would all 4 cells contain the same number of semicolons? If not, the logic of how to handle that case would be needed.

Hi Kenneth.

Thanks for your response.

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

Thanks!

Code:

---

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

---

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

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!

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!

Note that in my function, you need to set the reference by clicking Tools menu, References, and add that one.

Code:

---

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

---

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!

You might have made that slight amendment yourself.

Code:

---

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

---

Yes, I noticed that after I posted my code and read your post #6 and reread #1. I edited my post #8 code.

Here's my stab at it..

Code:

---

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

---

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.