VBA to Concatenate Multi-Value Cells

[lneidorf]

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]

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

[lneidorf]

Hi Kenneth.

Thanks for your response.

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

Thanks!

[snb]

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]

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]

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]

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]

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]

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]

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]

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

[apo]

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]

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.